エクセルのセル内の文字列をマクロを使ってmicrosoft wordの要約機能で自動要約するためのプログラムを探しています。

例としては

 |a列      |b列     
--------------------------
1行|10文字の文字列 |
2行|12文字の文字列 |

という状態があった場合、A1セルの内容をワードを解して要約しB1に要約した内容を返すというプラグラムを探しています。
以降A2に自動的に移動していき、どんどん要約結果を隣のセルに介してくれるプログラムを探しています。

完成時の一例
 |a列      |b列     
--------------------------
1行|10文字の文字列 |8文字ぐらいの文字列
2行|12文字の文字列 |9文字ぐらいの文字列

出来れば要約率が設定できるとありがたく思います。
使用できるエクセル、ワードは2003になります。
出来るだけの御礼はしますのでよろしくお願いします。

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2010/04/23 17:51:12
  • 終了:2010/04/30 17:55:02

ベストアンサー

id:HALSPECIAL No.2

HALSPECIAL回答回数407ベストアンサー獲得回数862010/04/23 20:43:34

ポイント35pt

ActiveDocument.AutoSummarize メソッドで要約します。

こんな感じでしょうか。

Option Explicit

Public Sub 要約実行()
    Const wdNewBlankDocument As Integer = 0
    Const wdSummaryModeCreateNew As Integer = 3
    '文書全体の長さに対する要約の長さの割合 (%)。数値が大きいほど詳細な内容が要約に含められます。
    Const AUTO_SUMMARIZE_LENGTH As Integer = 25
    
    Dim wk As String
    Dim objWord
    Set objWord = CreateObject("Word.Application")  'ワード起動
    objWord.Visible = False 'ワード非表示
    objWord.Documents.Add DocumentType:=wdNewBlankDocument
    
    Application.ScreenUpdating = False
    Cells(1, 1).Activate
    
    Do Until ActiveCell.Value = ""
        objWord.Selection.HomeKey
        objWord.Selection.TypeText Text:=ActiveCell.Value
        objWord.ActiveDocument.AutoSummarize Length:=AUTO_SUMMARIZE_LENGTH, Mode:=wdSummaryModeCreateNew, UpdateProperties:=False
        objWord.ActiveDocument.Select
        wk = objWord.Selection.Text
        If wk = vbCr Then
            '要約できない場合はそのままセット
            ActiveCell.Offset(0, 1).Value = ActiveCell.Value
        Else
            '要約を貼り付け
            ActiveCell.Offset(0, 1).Value = wk
        End If
        objWord.ActiveDocument.Close False
        objWord.ActiveDocument.Select
        objWord.Selection.Text = ""
        ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    Cells(1, 1).Activate
    Application.ScreenUpdating = True
    
    objWord.Quit False
    Set objWord = Nothing
    
End Sub

※要約率は、

Const AUTO_SUMMARIZE_LENGTH As Integer = 25

を調整してください。

※ある程度の文章でないと要約できないのではないでしょうか?

   10文字の文字列等では無理のような・・・

その他の回答(1件)

id:koriki-kozou No.1

koriki-kozou回答回数480ベストアンサー獲得回数792010/04/23 19:06:23

ポイント35pt

Wordの要約は単語を削ります

http://office.microsoft.com/ja-jp/word/HP052334521041.aspx


テストケースとしてご質問文を丸ごとWordに貼り付けて要約を実行すると以下のようになります

エクセルのセル内の文字列をマクロを使ってmicrosoft wordの要約機能で自動要約するためのプログラムを探しています。

例としては

 |a列      |b列     

--------------------------

1行|10文字の文字列 |

2行|12文字の文字列 |

という状態があった場合、A1セルの内容をワードを解して要約しB1に要約した内容を返すというプラグラムを探しています。

使用できるエクセル、ワードは2003になります。

ご覧の通り10文字から8文字に削るなどは出来ません

Wordの要約機能を誤解していると思います

もう少し具体的に文字列の変換例を出して別の案を募るほうが良いでしょう

id:yokosima_nhp

確かに説明が足りなかったですね。

2010/04/23 23:04:47
id:HALSPECIAL No.2

HALSPECIAL回答回数407ベストアンサー獲得回数862010/04/23 20:43:34ここでベストアンサー

ポイント35pt

ActiveDocument.AutoSummarize メソッドで要約します。

こんな感じでしょうか。

Option Explicit

Public Sub 要約実行()
    Const wdNewBlankDocument As Integer = 0
    Const wdSummaryModeCreateNew As Integer = 3
    '文書全体の長さに対する要約の長さの割合 (%)。数値が大きいほど詳細な内容が要約に含められます。
    Const AUTO_SUMMARIZE_LENGTH As Integer = 25
    
    Dim wk As String
    Dim objWord
    Set objWord = CreateObject("Word.Application")  'ワード起動
    objWord.Visible = False 'ワード非表示
    objWord.Documents.Add DocumentType:=wdNewBlankDocument
    
    Application.ScreenUpdating = False
    Cells(1, 1).Activate
    
    Do Until ActiveCell.Value = ""
        objWord.Selection.HomeKey
        objWord.Selection.TypeText Text:=ActiveCell.Value
        objWord.ActiveDocument.AutoSummarize Length:=AUTO_SUMMARIZE_LENGTH, Mode:=wdSummaryModeCreateNew, UpdateProperties:=False
        objWord.ActiveDocument.Select
        wk = objWord.Selection.Text
        If wk = vbCr Then
            '要約できない場合はそのままセット
            ActiveCell.Offset(0, 1).Value = ActiveCell.Value
        Else
            '要約を貼り付け
            ActiveCell.Offset(0, 1).Value = wk
        End If
        objWord.ActiveDocument.Close False
        objWord.ActiveDocument.Select
        objWord.Selection.Text = ""
        ActiveCell.Offset(1, 0).Activate
    Loop
    
    
    Cells(1, 1).Activate
    Application.ScreenUpdating = True
    
    objWord.Quit False
    Set objWord = Nothing
    
End Sub

※要約率は、

Const AUTO_SUMMARIZE_LENGTH As Integer = 25

を調整してください。

※ある程度の文章でないと要約できないのではないでしょうか?

   10文字の文字列等では無理のような・・・

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません