Excelにて語句を検索して一覧化するマクロ

開発現場にて、ツールの類がほとんどなく改良して作成したマクロ

Sub RunKeywordSearch_Fast()
    Dim varArray As Variant
    Dim strSearchInput As String
    Dim strFolderPath As String
    Dim fileList As New Collection
    Dim shtWrite As Worksheet
    Dim bokTarget As Workbook
    Dim shtTarget As Worksheet
    Dim data As Variant
    Dim r As Long, c As Long
    Dim cellValue As String
    Dim filePath As Variant
    Dim varWhat As Variant
    Dim fileFolderPath As String
    Dim results() As Variant
    Dim resultCount As Long
    Dim writeRow As Long
    Dim cellAddress As String
    Dim keyDict As Object
    Dim key As String
    Dim calcSetting As XlCalculation

    ' 前処理
    strSearchInput = Trim(ThisWorkbook.Sheets(1).Range("B3").Value)
    If Len(strSearchInput) = 0 Then MsgBox "検索ワードがありません（B3）": Exit Sub
    If InStr(strSearchInput, ",") > 0 Then
        varArray = Split(strSearchInput, ",")
    Else
        ReDim varArray(0): varArray(0) = strSearchInput
    End If

    strFolderPath = Trim(ThisWorkbook.Sheets(1).Range("B2").Value)
    strFolderPath = Replace(strFolderPath, "/", "\")
    If Right(strFolderPath, 1) = "\" Then strFolderPath = Left(strFolderPath, Len(strFolderPath) - 1)
    If Dir(strFolderPath, vbDirectory) = "" Then MsgBox "フォルダが存在しません（B2）": Exit Sub

    Call GetAllExcelFiles(strFolderPath, fileList)
    If fileList.Count = 0 Then MsgBox "Excelファイルが見つかりません": Exit Sub

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    calcSetting = Application.Calculation
    Application.Calculation = xlCalculationManual
    Set keyDict = CreateObject("Scripting.Dictionary")

    Set shtWrite = Workbooks.Add.Worksheets(1)
    shtWrite.Range("A1:B1").Value = Array("検索日時", Now())
    shtWrite.Range("A2:B2").Value = Array("フォルダ", strFolderPath)
    shtWrite.Range("A3:B3").Value = Array("検索値", Join$(varArray, ","))
    shtWrite.Range("A5:E5").Value = Array("ファイルのフォルダ", "ブック名", "シート名", "セルアドレス", "値")
    shtWrite.Range("A1:A3,A5:E5").Interior.Color = RGB(217, 217, 217)
    ReDim results(1 To 1000, 1 To 5)
    resultCount = 0

On Error GoTo ErrHandler
    For Each filePath In fileList
        If Dir(filePath) = "" Then
            Debug.Print "[スキップ: 存在しない] " & filePath
            GoTo SkipFile
        End If

        Debug.Print "[処理中] " & filePath

        Set bokTarget = Nothing
        On Error Resume Next
        Set bokTarget = Workbooks.Open(filePath, ReadOnly:=True, UpdateLinks:=False)
        On Error GoTo ErrHandler

        If bokTarget Is Nothing Then
            Debug.Print "[スキップ: 開けない] " & filePath
            GoTo SkipFile
        End If

        fileFolderPath = Left(bokTarget.FullName, InStrRev(bokTarget.FullName, "\") - 1)

        For Each shtTarget In bokTarget.Worksheets
            data = shtTarget.UsedRange.Value
            If IsArray(data) Then
                For r = 1 To UBound(data, 1)
                    For c = 1 To UBound(data, 2)
                        cellValue = CStr(data(r, c))
                        If Len(cellValue) > 0 Then
                            For Each varWhat In varArray
                                If InStr(cellValue, Trim(varWhat)) > 0 Then
                                    cellAddress = shtTarget.Cells(r, c).Address(0, 0)
                                    key = bokTarget.FullName & "|" & shtTarget.Name & "|" & cellAddress
                                    If Not keyDict.exists(key) Then
                                        resultCount = resultCount + 1
                                        If resultCount > UBound(results, 1) Then
                                            ReDim Preserve results(1 To resultCount + 1000, 1 To 5)
                                        End If
                                        results(resultCount, 1) = fileFolderPath
                                        results(resultCount, 2) = bokTarget.Name
                                        results(resultCount, 3) = shtTarget.Name
                                        results(resultCount, 4) = cellAddress
                                        results(resultCount, 5) = cellValue
                                        keyDict.Add key, True
                                    End If
                                    Exit For
                                End If
                            Next
                        End If
                    Next
                Next
            End If
        Next

        bokTarget.Close SaveChanges:=False
SkipFile:
    Next
    GoTo Finalize

ErrHandler:
    Debug.Print "[エラー発生] ファイル: " & filePath & " / 内容: " & Err.Description
    Resume SkipFile

Finalize:
    If resultCount > 0 Then
        shtWrite.Range("A6").Resize(resultCount, 5).Value = results
        shtWrite.Columns("A:D").AutoFit
        shtWrite.Columns("E:E").ColumnWidth = 100
    Else
        shtWrite.Parent.Close SaveChanges:=False
        MsgBox "検索対象は見つかりませんでした", vbInformation
    End If

    Application.Calculation = calcSetting
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub