フォルダ内の全Wordファイルから文字列を検索するExcelVBA

作成するVBAの要件

sheet1のB4セルに入力された文字列を検索する
検索対象のフォルダはマクロ実行時に選択する
検索単語と、検索単語以降で同じ行に記載された文字列を取得する

ExcelVBAの作成

Excelを新規作成しVisual Basicを開き、以下のコマンドを張り付ける

VBAのソースコード

Sub WordGet()

    Dim wdApp As Object
    Dim wDoc As Object
    Dim wDNext As Object
    
    
    Dim fdPath As String, keyWord As String
    Dim objFso As Object
    Dim objFolder As Object
    Dim objSelection As Object
    Dim r As Long
    Dim i As Long
    Dim j As Long
    r = 0
    i = 0


    Set wdApp = CreateObject("Word.Application")
    Application.FileDialog(msoFileDialogFolderPicker).Show
    fdPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    keyWord = ThisWorkbook.Sheets("sheet1").Range("B4")

    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFso.GetFolder(fdPath)


    For Each f In objFolder.Files

        sxx = Right(f.Name, 5)
        If 0 < InStr(sxx, ".doc") Then
            sxx = Left(f.Name, 1)
            If 0 = InStr(sxx, "~") Then
                r = r + 1
                ThisWorkbook.Sheets("sheet1").Cells(r + 4 + i, 2) = f.Name
                i = i + 1

                Set wDoc = wdApp.documents.Open(fdPath & "\" & f.Name, True) '読み取りモードで開く
                Set objSelection = wdApp.Selection
                objSelection.Find.Text = keyWord
                objSelection.Find.Forward = True

                Do While (1)
                    If objSelection.Find.Execute Then
                        i = i + 1
                            ThisWorkbook.Sheets("sheet1").Cells(r + 3 + i, 3) = objSelection.Paragraphs.first.Range.Text
                            j = 0
                        On Error Resume Next
                        Do While (1)
                            j = j + 1
                            ThisWorkbook.Sheets("sheet1").Cells(r + 3 + i, 4) = objSelection.Paragraphs(j).Next.Range.Text
                            If Err.Number <> 0 Then
                                Err.Clear
                                Exit Do
                            End If
                        Loop
                        On Error GoTo 0
                    Else
                        Exit Do
                    End If
                Loop
                wDoc.Close

            End If
        End If
     Next f

     Set objFso = Nothing
     Set objFolder = Nothing
     Set wdApp = Nothing

End Sub

参考：https://teratail.com/questions/153936