sample_ReadWordFromExcelVBA.bas

Option Explicit

Sub sample_ReadWordFromExcelVBA()
    ' ファイル名、拡張子検索用
    Dim objFso As Object
    Dim objF As Object
    Dim dir As String
    Dim ext As String
    Dim filelist() As String
    Dim picktag As String
    
    Set objFso = CreateObject("Scripting.FileSystemObject")
    dir = ThisWorkbook.Path ' 探索するWordファイルはこのExcelファイルと同一ディレクトリに入れること
    ext = "docx" ' 拡張子
    picktag = "*oo*" ' ファイル名でさらに絞りたい場合使用（特になければ "*" と入力）、ワイルドカードOKだが正規表現NG
    
    ' Wordファイルから文字列を取得する用
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim wdPar As Word.Paragraph
    Dim par_txt As String
    Dim param(1 To 3) As String ' 抽出したい行が含む文字列を格納、ワイルドカード・正規表現NG
    
    Set wdApp = New Word.Application
    param(1) = "aa"
    param(2) = "dd"
    param(3) = "ee"
    
    ' その他変数
    Dim i As Long
    Dim filepath As String
    Dim filename As Variant
    
    i = 0
    
    ' カレントディレクトリ内のファイルのうち
    ' 拡張子がextのもの+ファイル名にpicktagを含むものをflist()に抽出
    For Each objF In objFso.GetFolder(dir).Files
        If LCase(objFso.GetExtensionName(objF)) = LCase(ext) Then
            If objFso.GetFileName(objF) Like picktag Then
                i = i + 1
                ReDim Preserve filelist(1 To i)
                filelist(i) = objFso.GetFileName(objF)
                Debug.Print filelist(i)
            End If
        End If
    Next objF
    
    On Error GoTo myError
    '
    wdApp.Visible = False ' Word画面非表示
    For Each filename In filelist
        filepath = dir & "\" & filename
        Debug.Print "START: read " & filename
        Set wdDoc = wdApp.Documents.Open(filename:=filepath, ReadOnly:=True, Visible:=False)  ' 読み取り専用、画面非表示でWordファイルを開く
        For Each wdPar In wdDoc.Paragraphs
            par_txt = wdPar.Range.Text
            For i = 1 To UBound(param)
                If InStr(par_txt, param(i)) >= 1 Then
                    Debug.Print par_txt
                End If
            Next i
        Next wdPar
        wdDoc.Close
        Debug.Print "FINISH: read " & filename
    Next filename
    
    ' 各オブジェクトを開放してWordを閉じて終了
    Set objFso = Nothing
    Set objF = Nothing
    
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Debug.Print "fin"
    Exit Sub
myError:
    ' エラー時は各オブジェクトを開放してWordを閉じて終了
    Set objFso = Nothing
    Set objF = Nothing
    
    wdDoc.Close
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
    MsgBox "エラーが発生しました！マクロを終了します。"
End Sub