ExcelマクロをつかってWordファイルから脚注リストを抜き取る方法

2019/12/12 記載

フォルダに格納されいてるwordファイルの脚注情報を抜き取る方法について

プログラム初心者でもわかりやすいように、

• サブ階層からWordファイルのパスを取得する処理
• Wordファイルの注釈を取得処理

は、別メソッドにしています。
速さは意識していないので、速さを求められる際は改良してください。

Git HubにコミットしたExcelファイル

本プログラムでは、参照設定が必要になってきます。

• Microsoft office Object Library
• Microsoft Excel Object Library
• Microsoft Word Object Library

の3つのライブラリにつきましては、
パソコンでインストールしたoffice製品のバージョンによって、番号が異なる（私のパソコンでは、14.0）ので、気を付けてください。

最後にプログラムの全文を載せていますが、
この処理で注意するところは3点です。

Ⅰ. 子階層（サブフォルダ）の配下のファイルを探す際には、再帰処理を用いる
マクロでは、子階層のファイルは参照できない為、子階層配下のファイルを参照しようとする場合は、再帰処理を呼ばないといけません。

    'パスの取得
    For Each objFolders In objFs.GetFolder(path).SubFolders
        'サブフォルダまで検索するために再帰実行
        setWordFilePath objFolders.path
    Next

Wordファイルの操作をする際には、Wordオブジェクトを生成したのち、ファイルを開く

    'Wordオブジェクト生成
    Set wdApp = CreateObject("Word.Application")
    
    '対象のWordファイルをOPEN
    Set wdDoc = wdApp.Documents.Open(filePath, ReadOnly:=True)

Wordの脚注情報を取得する際には、WordオブジェクトのFootnesを使用
Footer内の注釈を取得する際には、.Footnotes.countから、脚注数を取得したのち、ループで脚注オブジェクトを取得します。
脚注オブジェクトに格納されているそれぞれの情報は以下のプロパティを用います。

項目	プロパティ
脚注番号	Text
脚注内容	Range

    With wdDoc
        'Footerに記載されている脚注数を取得
        noteCounts = .Footnotes.count
        
        '脚注ごとにループ
        For index = 1 To .Footnotes.count
        
            '脚注を格納する配列に値が設定されている場合
            If Not Not footNoteList Then
                ReDim Preserve footNoteList(UBound(footNoteList, 1), UBound(footNoteList, 2) + 1)
            
            '脚注を格納する配列に値が設定されていない場合
            Else
                ReDim Preserve footNoteList(3, 1)
            End If

            '脚注の配列に脚注情報を格納
            footNoteList(1, UBound(footNoteList, 2)) = filePath                                 'Wordのファイルパス
            footNoteList(2, UBound(footNoteList, 2)) = CStr(.Footnotes(index).Reference.Text)   '脚注番号
            footNoteList(3, UBound(footNoteList, 2)) = Trim(.Footnotes(index).Range)            '脚注内容
        Next
    End With

**全体のプログラムは以下に記載します。**

Option Explicit

'パスリスト
Private pathList() As String

'脚注リスト
Private footNoteList() As String

'===========================================
'   概要：Wordのフッダー情報を出力する
'   引数：
'===========================================
Sub フッダー情報出力()
        
    Dim rowNo As Integer        '行番号
    Dim index As Integer        'index
    
    
    '描画停止
    Application.ScreenUpdating = False
    
    'Excelのセルを初期化
    Rows("6:1000").Select
    selection.Delete Shift:=xlUp
    
    '配列のパスリストの初期化
    Erase pathList()
    
    '指定したパス配下にいるWordのファイルパスリストを取得
    Call setWordFilePath(Range("C2").Value)
    
    'パスリストの配列をループ
    For index = 1 To UBound(pathList)
       'Wordの脚注リストを取得する
       Call addCellIntoWordFoodData(pathList(index))
    Next
    
    'Excelのセルの開始行位置を設定
    rowNo = 6
    
    'ファイルパス、脚注情報をExcelのセルに記載
    For index = 1 To UBound(footNoteList, 2)
        Cells(rowNo, 1).Value = footNoteList(1, index)
        Cells(rowNo, 2).Value = footNoteList(2, index)
        Cells(rowNo, 3).Value = footNoteList(3, index)
        rowNo = rowNo + 1
    Next
    
    '描画再開
    Application.ScreenUpdating = True

End Sub

'======================================================================
'   概要：引数のパス配下に格納されているWordファイルのパスを取得し
'         共通変数の配列に格納する
'   引数：Wordファイルが格納されているパス
'======================================================================
Sub setWordFilePath(path As String)
    Dim objFs       As Object   'ファイルシステムオブジェクト
    Dim objFiles    As Object   'ファイルオブジェクト
    Dim objFolders  As Object   'フォルダオブジェクト
    Dim length      As Integer  '配列の要素数格納

    Set objFs = CreateObject("Scripting.FileSystemObject")
    
    'パスの取得
    For Each objFolders In objFs.GetFolder(path).SubFolders
        'サブフォルダまで検索するために再帰実行
        setWordFilePath objFolders.path
    Next

    'ファイル名の取得
    For Each objFiles In objFs.GetFolder(path).Files
        
        'wordファイルの場合
         If (LCase(objFs.GetExtensionName(objFiles)) = LCase("doc")) Then
            
           'パスリストの配列に値が設定されている場合
            If Not Not pathList Then
                length = UBound(pathList) + 1
            'パスリストの配列に値が設定されていない場合
            Else
                length = 1
            End If
            
            '配列の再宣言
            ReDim Preserve pathList(length)
            
            'パスリストの配列にパスを追加
            pathList(length) = objFiles.path
        End If
    Next
    
End Sub

'======================================================================
'   概要：引数のファイルパスから、Wordファイルをオープンしたのち、
'         注釈のリストを取得、配列に注釈のリストを追加する
'   引数：Wordファイルのパス
'======================================================================
Sub addCellIntoWordFoodData(filePath As String)
    Dim wdApp       As Word.Application 'Wordアプリケーション
    Dim wdDoc       As Word.Document    'Wordドキュメント
    Dim noteCounts  As Integer          'Footerに記載されている脚注数
    Dim index       As Integer          'インデックス
    
    'Wordオブジェクト生成
    Set wdApp = CreateObject("Word.Application")
    
    'Wordファイルを非表示
    wdApp.Visible = False
    
    '対象のWordファイルをOPEN
    Set wdDoc = wdApp.Documents.Open(filePath, ReadOnly:=True)
    With wdDoc
        'Footerに記載されている脚注数を取得
        noteCounts = .Footnotes.count
        
        '脚注ごとにループ
        For index = 1 To .Footnotes.count
        
            '脚注を格納する配列に値が設定されている場合
            If Not Not footNoteList Then
                ReDim Preserve footNoteList(UBound(footNoteList, 1), UBound(footNoteList, 2) + 1)
            
            '脚注を格納する配列に値が設定されていない場合
            Else
                ReDim Preserve footNoteList(3, 1)
            End If

            '脚注の配列に脚注情報を格納
            footNoteList(1, UBound(footNoteList, 2)) = filePath                                 'Wordのファイルパス
            footNoteList(2, UBound(footNoteList, 2)) = CStr(.Footnotes(index).Reference.Text)   '脚注番号
            footNoteList(3, UBound(footNoteList, 2)) = Trim(.Footnotes(index).Range)            '脚注内容
        Next
    End With
    
    'Wordオブジェクトクローズ
    wdDoc.Close
    wdApp.Visible = True
    wdApp.Quit
    Set wdApp = Nothing
End Sub