[Excel VBA] excel、word、pptのファイルの中の文字をgrepして新しいブックに結果を出力したい

## 参照設定

Alt + F11 でVBEを開く

メニュー「ツール」→「参照設定」

以下にチェックを入れる：

Microsoft Word XX.0 Object Library

Microsoft PowerPoint XX.0 Object Library

Microsoft Scripting Runtime（Dictionary使用時に便利）

## VBAコード

```vb
Sub GrepOfficeFiles()

    Dim fso As Object
    Dim folder As Object, file As Object
    Dim path As String
    Dim keyword As String
    Dim resultWB As Workbook
    Dim resultWS As Worksheet
    Dim row As Long
    
    Application.ScreenUpdating = False
    
    ' 検索キーワード
    keyword = InputBox("検索する文字列を入力してください：")
    If keyword = "" Then Exit Sub

    ' 検索対象フォルダ
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "検索対象フォルダを選択"
        If .Show <> -1 Then Exit Sub
        path = .SelectedItems(1)
    End With

    
    
    ' 結果出力用ブック
    Set resultWB = Workbooks.Add
    Set resultWS = resultWB.Sheets(1)
    ' ヘッダー部分（GrepOfficeFiles内）
    resultWS.Range("A1:E1").Value = Array("ファイル名", "ファイルパス", "ファイル種別", "詳細位置", "一致箇所")

    row = 2

    ' FileSystemObjectでファイル巡回
    Set fso = CreateObject("Scripting.FileSystemObject")
    Call SearchFiles(fso.GetFolder(path), keyword, resultWS, row)
    Set fso = Nothing
        
    Application.ScreenUpdating = True
        
    MsgBox "検索完了しました。"


End Sub

Sub SearchFiles(folder As Object, keyword As String, resultWS As Worksheet, ByRef row As Long)
    Dim file As Object, subFolder As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each file In folder.Files
        Select Case LCase(fso.GetExtensionName(file.Name))
            Case "xlsx"
                Call SearchExcel(file.path, keyword, resultWS, row)
            Case "docx"
                Call SearchWord(file.path, keyword, resultWS, row)
            Case "pptx"
                Call SearchPPT(file.path, keyword, resultWS, row)
        End Select
    Next
    For Each subFolder In folder.SubFolders
        Call SearchFiles(subFolder, keyword, resultWS, row)
    Next
    Set fso = Nothing
End Sub

' Excel部分（SearchExcel）
Sub SearchExcel(filePath As String, keyword As String, resultWS As Worksheet, ByRef row As Long)
    On Error Resume Next
    Dim wb As Workbook, ws As Worksheet
    Set wb = Workbooks.Open(filePath, ReadOnly:=True, UpdateLinks:=False)
    If wb Is Nothing Then Exit Sub

    For Each ws In wb.Worksheets
        Dim cell As Range
        For Each cell In ws.UsedRange
            If InStr(1, cell.Text, keyword, vbTextCompare) > 0 Then
                resultWS.Cells(row, 1).Value = wb.Name
                resultWS.Cells(row, 2).Value = wb.FullName
                resultWS.Cells(row, 3).Value = "Excel"
                resultWS.Cells(row, 4).Value = ws.Name & "!" & cell.Address
                resultWS.Cells(row, 5).Value = cell.Text
                row = row + 1
            End If
        Next
    Next
    
    ' --- 既存のセル内検索の後に追加 ---
    Dim shp As shape
    For Each shp In ws.Shapes
        If shp.HasTextFrame Then
            If shp.TextFrame.HasText Then
                If InStr(1, shp.TextFrame.Characters.Text, keyword, vbTextCompare) > 0 Then
                    resultWS.Cells(row, 1).Value = wb.Name
                    resultWS.Cells(row, 2).Value = wb.FullName
                    resultWS.Cells(row, 3).Value = "Excel(図形)"
                    resultWS.Cells(row, 4).Value = ws.Name & ": Shape """ & shp.Name & """"
                    resultWS.Cells(row, 5).Value = shp.TextFrame.Characters.Text
                    row = row + 1
                End If
            End If
        End If
    Next
    wb.Close False
    On Error GoTo 0
End Sub

' Word部分（SearchWord）
Sub SearchWord(filePath As String, keyword As String, resultWS As Worksheet, ByRef row As Long)
    On Error Resume Next
    Dim wdApp As Object, doc As Object, para As Object
    Dim i As Long
    Set wdApp = CreateObject("Word.Application")
    Set doc = wdApp.Documents.Open(filePath, ReadOnly:=True)

    i = 1
    For Each para In doc.Paragraphs
        If InStr(1, para.Range.Text, keyword, vbTextCompare) > 0 Then
            resultWS.Cells(row, 1).Value = doc.Name
            resultWS.Cells(row, 2).Value = doc.FullName
            resultWS.Cells(row, 3).Value = "Word"
            resultWS.Cells(row, 4).Value = "段落 " & i
            resultWS.Cells(row, 5).Value = Trim(para.Range.Text)
            row = row + 1
        End If
        i = i + 1
    Next

    Dim shp As Object
    For Each shp In doc.Shapes
        If shp.TextFrame.HasText Then
            If InStr(1, shp.TextFrame.TextRange.Text, keyword, vbTextCompare) > 0 Then
                ' 結果出力
            End If
        End If
    Next
    
    ' --- 段落検索の後に追加 ---
    Dim shp As Object
    For Each shp In doc.Shapes
        If shp.TextFrame.HasText Then
            If InStr(1, shp.TextFrame.TextRange.Text, keyword, vbTextCompare) > 0 Then
                resultWS.Cells(row, 1).Value = doc.Name
                resultWS.Cells(row, 2).Value = doc.FullName
                resultWS.Cells(row, 3).Value = "Word(図形)"
                resultWS.Cells(row, 4).Value = "Shape: " & shp.Name
                resultWS.Cells(row, 5).Value = Trim(shp.TextFrame.TextRange.Text)
                row = row + 1
            End If
        End If
    Next
    doc.Close False
    wdApp.Quit
    On Error GoTo 0
End Sub

' PowerPoint部分（SearchPPT）
Sub SearchPPT(filePath As String, keyword As String, resultWS As Worksheet, ByRef row As Long)
    On Error Resume Next
    Dim pptApp As Object, pres As Object, slide As Object, shape As Object
    Dim slideNum As Long
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pres = pptApp.Presentations.Open(filePath, WithWindow:=False)

    For Each slide In pres.Slides
        slideNum = slide.SlideIndex
        For Each shape In slide.Shapes
            If shape.HasTextFrame Then
                If shape.TextFrame.HasText Then
                    If InStr(1, shape.TextFrame.TextRange.Text, keyword, vbTextCompare) > 0 Then
                        resultWS.Cells(row, 1).Value = pres.Name
                        resultWS.Cells(row, 2).Value = pres.FullName
                        resultWS.Cells(row, 3).Value = "PowerPoint"
                        resultWS.Cells(row, 4).Value = "スライド " & slideNum
                        resultWS.Cells(row, 5).Value = shape.TextFrame.TextRange.Text
                        row = row + 1
                    End If
                End If
            End If
        Next
    Next

    ' --- 既存の shape.TextFrame チェックの後に追加 ---
    If shape.HasTable Then
        Dim r As Long, c As Long
        For r = 1 To shape.Table.Rows.Count
            For c = 1 To shape.Table.Columns.Count
                If InStr(1, shape.Table.cell(r, c).shape.TextFrame.TextRange.Text, keyword, vbTextCompare) > 0 Then
                    resultWS.Cells(row, 1).Value = pres.Name
                    resultWS.Cells(row, 2).Value = pres.FullName
                    resultWS.Cells(row, 3).Value = "PowerPoint(表)"
                    resultWS.Cells(row, 4).Value = "スライド " & slideNum & ": 表セル(" & r & "," & c & ")"
                    resultWS.Cells(row, 5).Value = shape.Table.cell(r, c).shape.TextFrame.TextRange.Text
                    row = row + 1
                End If
            Next
        Next
End If
    pres.Close
    pptApp.Quit
    On Error GoTo 0
End Sub
```