ワード文書中の単語を抽出してエクセルに出力するマクロ【図解】

このマクロは、ワード文書中の単語を自動で抽出して、単語リストをエクセルファイルとしてデスクトップ上に出力するマクロ（Word VBA）です。

このマクロを実行して出力されるエクセルファイルでは、抽出される単語が頻度順に並ぶため、ワード文書中の頻出単語を把握するのにも便利です。

\Word VBAを学べる貴重な一冊 /

概要

以下に、このマクロの概要を示します。

このマクロのは、上のイラストの通り、アイコンをクリックするとワード文書中の単語を自動収集します。

収集が終了すると、エクセルファイルがデスクトップに自動生成されます。

エクセルファイル中には、「単語」、「頻度」、「文字数」のデータが入っています。

このように非常にシンプルな機能のマクロです。

詳細説明

マクロの準備

１．こちらの記事に記載したステップ①の手順１～６までを実施した後、ステップ①の手順７で、この記事の最後にあるコードを標準モジュールのＭodule1にコピペします。

コピペすると、以下の状態になります。

２．こちらの記事に記載したステップ①の手順８から２２までを行います

（ステップ①の１１では、「Project.Module1.WordCountAndExportToExcel」を選択してから、追加ボタンを押してください（以下のイラストのようにしてください））

（ステップ①の１３では、お好きなアイコンを選んでください）

（ステップ①の２０での保存名は何でもかまいません）

３．こちらの記事に記載したステップ②を行います

ステップ②を行うことで、このマクロをどのワード文書からも呼び出せるようになります。

（このマクロは、単語を抽出したい文書を開いて、そこからマクロを呼び出すことが基本の使用方法になるため、ステップ②を行った方が便利です）

以上でマクロの準備が整いました。

マクロの使用方法

以下の手順で簡単にマクロを実行できます（念のため、データのバックアップ後に実行するようにしてください）

１．単語をピックアップしたいワード文書を開きます（上記の「マクロの準備」でステップ②まで実施した人）

ステップ①のみを実施した人はマクロのdotmファイルを開き（上部にセキュリティ警告が出た場合は、「コンテンツの有効化」をクリックしてください）、そのdotmファイルに、単語抽出を行いたい文章をコピペしてください。

２．マクロを実行します。

（アイコンは、各自が選んだアイコンになります）

３．大文字小文字の区別と全角半角の区別を選択します

マクロを実行すると、上のイラストのメッセージがでます。

大文字と小文字の区別を選択してください。

次に、以下のイラストのメッセージがでますので、全角と半角の区別を選択してください。

全角と半角のの区別の選択を行うと、自動で抽出が始まります。

ワード文書画面の左下に、以下のイラストのように進行状況が表示されます。

抽出が終了すると、以下のメッセージが出て、エクセルファイルが自動で開きます。

以下は、出力されるエクセルファイル（抽出結果）の例です。

このエクセルファイルは、デスクトップ上に保存されています。

以上がこのマクロの実行の流れです。

大文字小文字の区別、ならびに全角半角の区別について

大文字小文字の区別、ならびに全角半角の区別の有無で単語がどのように抽出されるかを以下の表にまとめました。

単語	大文字小文字区別	全角半角区別	抽出結果
ジャパン ｼﾞｬﾊﾟﾝ	なし	なし
	あり	なし
	なし	あり
	あり	あり
japan Japan JAPAN ｊａｐａｎ Ｊａｐａｎ ＪＡＰＡＮ	なし	なし
	あり	なし
	なし	あり
	あり	あり

全角と半角の区別について

全角と半角の区別をしない場合、すべての単語が半角に変換されてから抽出が行われます。

例えば、全角の「ジャパン」は半角の「ｼﾞｬﾊﾟﾝ」に変換されてから抽出が行われます。

「ＪＡＰＡＮ」の場合は「JAPAN」に変換されてから抽出が行われます。

全角と半角の区別をする場合、同じ単語であっても全角半角のパターンが異なる単語は、そのまま別々の単語として抽出されます。

大文字と小文字の区別について

大文字と小文字を区別しない場合、すべての単語が小文字に変換されてから抽出が行われます。

例えば、「JAPAN」は「japan」に変換されてから抽出され、「ＪＡＰＡＮ」は「ｊａｐａｎ」に変換されてから抽出されます。

大文字と小文字の区別をする場合、同じ単語であっても大文字小文字のパターンが異なる単語は、そのまま別々の単語として抽出されます。

単語抽出結果のエクセルファイルについて

エクセルファイルの保存について

マクロの処理が終了すると、結果のエクセルファイルがデスクトップ上に作成されます。

エクセルファイルの名前は、単語抽出対象のワードファイル名に抽出条件が付加された名前になります。

例えば、「テスト.docx」という名前のワードファイル中の単語を大文字小文字区別あり、全角半角区別ありで抽出した場合、

「テスト.docx（大文字小文字区別あり、全角半角区別あり）.xlsx」という名前のファイルがデスクトップ上に作成されます。

同じ名前のファイルがデスクトップ上に既に存在する場合は、上書きは行われず、ファイル名の末尾に(1)などの番号が付加されて別ファイルがデスクトップ上に作成されます。

エクセルファイルの内容について

抽出結果は、以下の例ような内容になります。

例１．日本語文書の単語の抽出例

例２．英語文書の単語の抽出例

単語は頻度の降順に並びます。

同じ頻度の単語は、文字数の降順に並びます。

単語の抽出は、ワードが単語だと認識する単位で行われますので、必ずしも使用者の意図する単語の抽出になるわけでないことをご了承ください。

単語の並びを変えたい場合は、エクセルのオートフィルター機能などお使いください。

マクロの詳細説明は以上になります。

コード

以下は、本マクロのコードです。

上で説明したように標準モジュールにコピペしてご使用ください。

（以下のコードをすべて選択して、そのまま貼り付けてください）

コードの貼り付けの説明に戻る場合は、ここをクリックしてください。

現在の公開バージョンは、V01L07です。

Sub WordCountAndExportToExcel()
' V01L07    
    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

コードの貼り付けの説明に戻る場合は、ここをクリックしてください。

以上でこのマクロの紹介は終わりです。