目次
概要
このマクロは、ワード文書中の単語を自動で抽出し、単語リストをエクセルファイルとしてデスクトップ上に出力するマクロです。
以下に、このマクロの概要を示します。
このマクロのは、上のイラストの通り、アイコンをクリックするとワード文書中の単語を自動収集します。
収集が終了すると、エクセルファイルがデスクトップに自動生成されます。
エクセルファイル中には、「単語」、「頻度」、「文字数」のデータが入っています。
このように非常にシンプルな機能のマクロです。
詳細説明
マクロの準備
１．こちらの記事に記載したステップ①の１～６までを実施した後、ステップ①の７で、この記事の最後にあるコードを標準モジュールのＭodule1にコピペします。
コピペすると、以下の状態になります。
２．こちらの記事に記載したステップ①の８から２２までを行います
（ステップ①の１１では、「Project.Module1.WordCountAndExportToExcel」を選択してから、追加ボタンを押してください（以下のイラストのようにしてください））
（ステップ①の１３では、お好きなアイコンを選んでください）
（ステップ①の２０での保存名は何でもかまいません）
以上でマクロの準備が整いました。
このマクロをどのワード文書からも呼び出せるようにしたい場合は、こちらの記載したステップ②も行ってください。
（このマクロは、単語を抽出したい文書を開いて、そこからマクロを呼び出すことが基本の使用方法になるため、ステップ②を行う方が便利です）
マクロの使用方法
以下の手順で簡単にマクロを実行できます（念のため、データのバックアップ後に実行するようにしてください）
１．単語をピックアップしたいワード文書を開きます（上記の「マクロの準備」でステップ②まで実施した人）
ステップ①のみを実施した人はマクロのdotmファイルを開き（上部にセキュリティ警告が出た場合は、「コンテンツの有効化」をクリックしてください）、そのdotmファイルに、単語抽出を行いたい文章をコピペしてください。
２．マクロを実行します。
（アイコンは、各自が選んだアイコンになります）
３．大文字小文字の区別と全角半角の区別を選択します
マクロを実行すると、上のイラストのメッセージがでます。
大文字と小文字の区別を選択してください。
次に、以下のイラストのメッセージがでますので、全角と半角の区別を選択してください。
全角と半角のの区別の選択を行うと、自動で抽出が始まります。
左下に、以下のイラストのような進行状況が表示されます。
抽出が終了すると、以下のメッセージが出て、エクセルファイルが自動で開きます。
以下は、出力されるエクセルファイル（抽出結果）の例です。
このエクセルファイルは、デスクトップ上に作成されています。
以上がこのマクロの実行の流れです。
大文字小文字の区別、ならびに全角半角の区別について
大文字小文字の区別、ならびに全角半角の区別の有無で単語がどのように抽出されるかを以下の表にまとめました。
| 単語 | 大文字小文字区別 | 全角半角区別 | 抽出結果 |
|---|---|---|---|
| ジャパン ｼﾞｬﾊﾟﾝ | なし | なし |  |
| あり | なし |  | |
| なし | あり |  | |
| あり | あり |  | |
| japan Japan JAPAN ｊａｐａｎ Ｊａｐａｎ ＪＡＰＡＮ | なし | なし |  |
| あり | なし |  | |
| なし | あり |  | |
| あり | あり |  |
全角と半角の区別について
全角と半角の区別をしない場合、すべての単語が半角に変換されてから抽出が行われます。
例えば、全角の「ジャパン」は半角の「ｼﾞｬﾊﾟﾝ」に変換されてから抽出が行われます。
「ＪＡＰＡＮ」の場合は「JAPAN」に変換されてから抽出が行われます。
全角と半角の区別をする場合、これらはそのまま別々の単語として抽出されます。
大文字と小文字の区別について
大文字と小文字を区別しない場合、すべての単語が小文字に変換されてから抽出が行われます。
例えば、「JAPAN」は「japan」に変換されてから抽出され、「ＪＡＰＡＮ」は「ｊａｐａｎ」に変換されてから抽出されます。
大文字と小文字の区別をする場合、これらはそのまま別々の単語として抽出されます。
単語抽出結果のエクセルファイルについて
エクセルファイルの保存について
マクロの処理が終了すると、結果のエクセルファイルがデスクトップ上に作成されます。
エクセルファイルの名前は、単語抽出対象のワードファイル名に抽出条件が付加された名前になります。
例えば、「テスト.docx」という名前のワードファイル中の単語を大文字小文字区別あり、全角半角区別ありで抽出した場合、
「テスト.docx（大文字小文字区別あり、全角半角区別あり）.xlsx」という名前のファイルがデスクトップ上に作成されます。
既に同じ名前のファイルがデスクトップ上に存在する場合は、上書きせずに末尾に(1)などの番号が付加された別ファイルとしてデスクトップ上に保存されます。
エクセルファイルの内容について
抽出結果は、以下の例ような内容になります。
例１．日本語文書の単語の抽出例
例２．英語文書の単語の抽出例
単語は頻度の降順に並びます。
同じ頻度の単語は、文字数の降順に並びます。
単語の抽出は、ワードが単語だと認識する単位で行われますので、必ずしも使用者の意図する単語の抽出になるわけでないことをご了承ください。
単語の並びを変えたい場合は、エクセルのオートフィルター機能などお使いください。
マクロの詳細説明は以上になります。
コード
以下は、本マクロのコードです。
上で説明したように標準モジュールにコピペしてご使用ください。
（以下のコードをすべて選択して、そのまま貼り付けてください）
コードの貼り付けの説明に戻る場合は、ここをクリックしてください。
現在の公開バージョンは、V01L07です。
Sub WordCountAndExportToExcel()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim WordRange As Word.Range
Dim WordTable As Word.Table
Dim WordFrequency As Object
Dim WordItem As Variant
Dim ExcelApp As Object
Dim ExcelWb As Object
Dim ExcelWs As Object
Dim FilePath As String
Dim FileName As String
Dim i As Integer
Dim TotalWords As Long
Dim CountedWords As Long
Dim LastUpdate As Long
Dim LastExcelUpdate As Long
' 大文字と小文字を区別するかどうかを尋ねる
Dim CaseSensitive As VbMsgBoxResult
CaseSensitive = MsgBox("大文字と小文字を区別しますか？", vbYesNo, "選択してください")
' 全角と半角を区別するかどうかを尋ねる
Dim FullWidthAndHalfWidthSensitive As VbMsgBoxResult
FullWidthAndHalfWidthSensitive = MsgBox("全角と半角を区別しますか？", vbYesNo, "選択してください")
' Wordの設定
Set WordApp = Word.Application
Set WordDoc = WordApp.ActiveDocument
Set WordRange = WordDoc.Content
' 単語の頻度をカウント
TotalWords = WordRange.Words.Count ' 総単語数を取得
Set WordFrequency = CreateObject("Scripting.Dictionary")
For Each WordItem In WordRange.Words
' 改行はカウントの対象外とする
If WordItem = vbCr Or WordItem = vbLf Or WordItem = vbCrLf Then
TotalWords = TotalWords - 1
GoTo NextWord
End If
WordItem = Trim(WordItem)
If CaseSensitive = vbNo Then
WordItem = LCase(WordItem)
End If
If FullWidthAndHalfWidthSensitive = vbNo Then
WordItem = StrConv(WordItem, vbNarrow)
End If
If WordFrequency.Exists(WordItem) Then
WordFrequency(WordItem) = WordFrequency(WordItem) + 1
Else
WordFrequency.Add WordItem, 1
End If
CountedWords = CountedWords + 1 ' カウント済単語数を更新
' 全単語数の1%ごとにステータスバーを更新
If CountedWords >= LastUpdate + TotalWords / 100 Then
WordApp.StatusBar = "単語のカウント中: " & Format(CountedWords / TotalWords, "0%") ' 進捗状況を更新
LastUpdate = CountedWords ' 最後に更新した時のカウント済単語数を更新
End If
NextWord:
Next WordItem
' 単語が存在しない場合、メッセージを表示して処理を終了
If WordFrequency.Count = 0 Then
MsgBox "単語が存在ません。処理を終了します。", vbInformation
' オブジェクトの解放 ' 変更点
Set WordRange = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
Exit Sub ' 変更点
End If
WordApp.StatusBar = "Excelへの出力の準備をしています"
' Excelの設定
Set ExcelApp = CreateObject("Excel.Application")
Set ExcelWb = ExcelApp.Workbooks.Add
Set ExcelWs = ExcelWb.Sheets(1)
' 項目名を設定
ExcelWs.Cells(1, 1).Value = "単語"
ExcelWs.Cells(1, 2).Value = "頻度"
ExcelWs.Cells(1, 3).Value = "文字数"
' 単語とその頻度をExcelに出力
i = 2
Dim WordItems As Variant
WordItems = WordFrequency.Keys
Dim Frequencies As Variant
Frequencies = WordFrequency.Items
Dim n As Long
Dim j As Long
Dim TempFreq As Variant
Dim TempWord As Variant
n = WordFrequency.Count
For i = 2 To n + 1
For j = i + 1 To n + 1
If Frequencies(i - 2) < Frequencies(j - 2) Or _
(Frequencies(i - 2) = Frequencies(j - 2) And Len(WordItems(i - 2)) < Len(WordItems(j - 2))) Then
TempFreq = Frequencies(i - 2)
Frequencies(i - 2) = Frequencies(j - 2)
Frequencies(j - 2) = TempFreq
TempWord = WordItems(i - 2)
WordItems(i - 2) = WordItems(j - 2)
WordItems(j - 2) = TempWord
End If
Next j
Next i
For i = 2 To n + 1
ExcelWs.Cells(i, 1).Value = "'" & WordItems(i - 2)
ExcelWs.Cells(i, 2).Value = Frequencies(i - 2)
ExcelWs.Cells(i, 3).Value = Len(WordItems(i - 2))
' Excel出力行数の1%ごとにステータスバーを更新
If i >= LastExcelUpdate + (n + 1) / 100 Then
WordApp.StatusBar = "Excelへの出力中: " & Format(i / (n + 1), "0%") ' 進捗状況を更新
LastExcelUpdate = i ' 最後に更新した時のExcel出力行数を更新
End If
Next i
' ファイル名の設定
FileName = WordDoc.Name
If CaseSensitive = vbYes Then
FileName = FileName & "（大文字小文字区別あり、"
Else
FileName = FileName & "（大文字小文字区別なし、"
End If
If FullWidthAndHalfWidthSensitive = vbYes Then
FileName = FileName & "全角半角区別あり）"
Else
FileName = FileName & "全角半角区別なし）"
End If
FilePath = Environ$("USERPROFILE") & "\Desktop\" & FileName & ".xlsx"
i = 1
While Dir(FilePath) <> ""
FilePath = Environ$("USERPROFILE") & "\Desktop\" & FileName & "(" & CStr(i) & ").xlsx"
i = i + 1
Wend
' Excelファイルを保存
ExcelWb.SaveAs FilePath
ExcelApp.Visible = True
' 処理が終了しました。
WordApp.StatusBar = "処理が終了しました。"
' 終了メッセージを表示
MsgBox "処理が終了しました。このエクセルファイルはデスクトップに保存されています。", vbInformation
' オブジェクトの解放
Set WordRange = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing
Set ExcelWs = Nothing
Set ExcelWb = Nothing
Set ExcelApp = Nothing
End Subコードの貼り付けの説明に戻る場合は、ここをクリックしてください。
以上でこのマクロの紹介は終わりです。
最後まで読んでいただきましてありがとうございました！
よろしければ、他のマクロも是非見て行ってください。