【Excel VBA】Wordファイルのブックマーク情報でExcelに一覧出力するサンプル

Word文書の一部を抽出、一覧にして集計や分析に活用したいときのサンプル、第2回目です。

今回のマクロは、指定したWordファイル（.docx 形式）に設定されたブックマーク名と、その範囲のテキストをExcelのシートに一覧出力するサンプルです。

内容

アウトプットイメージ
VBAサンプル
応用ポイント

アウトプットイメージ

下図の左側は、Wordファイル内に設定された複数のブックマークです。
それぞれのブックマークには、文書内の特定の範囲が指定されています。

このマクロを実行すると、下図右側のように、ブックマーク名とその範囲のテキストがExcelの「ブックマーク一覧」シートに一覧形式で出力されます。

Wordファイル内に設定されたブックマークの対象範囲（文字列）が一覧出力されている — ブックマークが設定された文字列をExcelに一覧出力するアウトプットイメージ

上図左側のWord文書では、“ [ ] ”の範囲がブックマーク箇所で示されており、ブックマークの設定画面では以下のとおりです。

Word文書内にhiduke,kinyuusya などのブックマークが設定されている — 設定されているブックマーク一覧

VBAサンプル

VBAのサンプルは次のとおりです。

前提として、VBAを実行するExcelファイルには、あらかじめ出力用のシート「ブックマーク一覧」が作成されている必要があります。

Sub Wordファイルのブックマーク情報をExcelに一覧出力するサンプル()

    ' === 変数宣言 ===
    Dim ワードアプリ As Object
    Dim ドキュメント As Object
    Dim ファイル名 As Variant
    Dim 出力シート As Worksheet
    Dim 出力行 As Long
    Dim ブックマーク As Object

    ' === Wordアプリケーションの起動 ===
    Set ワードアプリ = CreateObject("Word.Application")

    ' === Wordファイルの選択 ===
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "抽出対象のWordファイルを選択"
        .Filters.Clear
        .Filters.Add "Wordファイル", "*.docx"

        If .Show = -1 Then
            ファイル名 = .SelectedItems(1)
        Else
            MsgBox "ファイルが選択されませんでした。処理を中止します。"
            Exit Sub
        End If
    End With

    ' === Word文書のオープン ===
    Set ドキュメント = ワードアプリ.Documents.Open(ファイル名)

    ' === 出力先シートの過去データのクリアと準備 ===
    Set 出力シート = ThisWorkbook.Sheets("ブックマーク一覧")
    出力シート.Cells.ClearContents
    出力シート.Cells(1, 1).Value = "ブックマーク名"
    出力シート.Cells(1, 2).Value = "範囲のテキスト"

    ' === ブックマークの抽出と出力 ===
    出力行 = 2
    For Each ブックマーク In ドキュメント.Bookmarks
        出力シート.Cells(出力行, 1).Value = ブックマーク.Name
        出力シート.Cells(出力行, 2).Value = Replace(ブックマーク.Range.Text, Chr(13) & Chr(7), "")
        出力行 = 出力行 + 1
    Next ブックマーク

    ' === Word文書とアプリケーションの終了処理 ===
    AppActivate Application.Caption
    MsgBox "ブックマーク情報の抽出が完了しました。"

    ドキュメント.Close False
    Set ドキュメント = Nothing

    ワードアプリ.Quit
    DoEvents
    Set ワードアプリ = Nothing

End Sub