そんなことしたら日が暮れるわ！！！

そう思いながら Excel ファイルをひとつひとつ探した。

そんなつらい思いをされた方もいるかもしれません。

また Excel ファイルというのは、外部ツール（たとえばサクラエディタの grep 機能など）で検索できません。

そんな状況で大量の Excel ファイル から文字検索するの～～～

ですが、そんな悩みも今日で解消です。

この度、サブフォルダ含むすべてのフォルダの Excel を文字検索するマクロを作成しました！！

このページではサブフォルダ含むすべてのフォルダの Excel を文字検索するマクロの使い方と作成方法についてご紹介します。

もしよければ参考にしてみてください。

※ いつものようにつくったのも共有しときますので、よければどうぞ。

※ 2022/02/07 マクロに一部バグがあったので、修正しました。

まず検索ワードを B3 セルになんでもいいのでいれます。

この時入力し忘れていれば、後の検索処理できないようになっています。

そして検索ボタンを押下します。

するとフォルダダイアログが表示されます。

ここでは検索先のフォルダを選択してOKをクリックします。

検索処理が実行され、検索結果が表示されます。

ここで「サブフォルダ含むすべてのフォルダの Excel を文字検索するマクロ」の仕様について書いておきます。

「サブフォルダ含むすべてのフォルダの Excel を文字検索するマクロ」の作り方です。

今回は Excel VBA をつかって処理を実現しています。

処理の中身はこんな感じになっています。

多いように見えますが、これを処理に起こせば「サブフォルダ含むすべてのフォルダの Excel を文字検索するマクロ」は実現できます。

定数と変数を定義

まずはこれらを VBA 処理上でよく使う定数と変数を定義します。

出力先シート「search」の初期化

つぎに出力先シート「search」を初期化する処理です。

これは出力する初期の列、行（つまり A6セル）から Excel の最終セルの範囲で値を削除します。

' シートの初期化
Private Sub reset()

Application.ScreenUpdating = False

Range(Cells(CELL_PRINT_ROW, CELL_PRINT_COL), Cells(Rows.Count, Columns.Count)).ClearContents

Application.ScreenUpdating = True

End Sub

フォルダダイアログを表示してフォルダパスを取得

つぎにフォルダダイアログを表示させてフォルダパスを取得します。

フォルダダイアログっていうのはこれです↓

Application.FileDialog(msoFileDialogFolderPicker)を用いることで

フォルダダイアログで選択しその結果がフォルダパスが取得できます。

またキャンセルが押下された場合、そのまま処理が終了するように条件分岐しています。

Private Function getFolderName()

    Dim folderPath As Variant
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = 0 Then
            End
        End If
        folderPath = .SelectedItems(1)
    End With
    
    getFolderName = folderPath
  
End Function

取得したフォルダパスをもとに Excel ファイル一覧を取得

前章「フォルダダイアログを表示してフォルダパスを取得」で取得したフォルダパスしたパスをもとに

Excel ファイル一覧を取得します。

' 再帰的にファイルを検索
Private Sub searchFile(ByVal Path As String, ByRef myBook As Workbook)

    On Error Resume Next

    Dim buf As String, f As Object
    buf = Dir(Path & SEARCH_WORD)
    
    searchWord = Range(CELL_SEARCH_WORD)
        
    Do While buf <> ""
        
        Call grepExcel(searchWord, myBook, Path, buf)
        buf = Dir()
        
    Loop
    
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Path).SubFolders
            Call searchFile(f.Path, myBook)
        Next f
    End With

End Sub

フォルダパスの値が Path という変数に格納されていますが、これを Dir 関数に渡すことで

フォルダのフルパスが取得できます。

myBookとは今回作成するマクロ自体の情報を格納しています。

これをすることで検索結果出力先のシートをわかりやすくしています。

（検索結果を書き込む際に myBook を呼び出せば、間違えずに書き込むことができます）。

またサブフォルダを含めて計算するために再帰処理にしています。

つまり 上記の searchFile() が処理が完了した後にそのフォルダ内にサブフォルダがあれば、

もう一回 searchFile() を呼び出しています。

これをすることでフォルダ内にサブフォルダがなくなるまでずーっと処理が続くようになっています。

取得した Excel ファイルを開き、Cells.Find をつかって文字を検索

ここでは 前章「取得したフォルダパスをもとに Excel ファイル一覧を取得」で取得した

Excel ファイルをopen で開き、その開いたファイルのシート一つ一つに対して

Cells.Find をつかって文字検索を実施します。

この際に、文字検索結果が複数ある場合も考慮し、

Cells.FindNextをつかって次の検索文字がなくなるまでループ処理をします。

' Excel ファイル内の文字検索
Private Sub grepExcel(ByVal searchWord, ByRef myBook As Workbook, ByVal Path As String, ByVal buf As String)

    Dim filePath
    Dim wb As Workbook
    Dim readSheet As Worksheet
    Dim Rng As Range
    Dim findResult

    fullPath = Path & "\" & buf

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Set wb = Workbooks.Open(Filename:=fullPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True, Password:="")
    
    If Err.Number = 1004 Then
        
        Err.Clear
    
    Else
    
        For Each mysheet In wb.Worksheets
            
            Set findResult = mysheet.Cells.Find(searchWord, LookAt:=xlPart)
            Dim findCell As Range
            Set findCell = findResult
            
            If Not (findCell Is Nothing) And Not (findResult Is Nothing) Then
            
                Do
                    If Not (findCell Is Nothing) And Not (findResult Is Nothing) Then
                        Call writeSheet(myBook, Path, buf, mysheet, findCell)
                        Set findCell = mysheet.Cells.FindNext(findCell)
                        If findCell Is Nothing Then
                            Exit For
                        End If
                    Else
                        Exit For
                    End If
                Loop While findCell.Row <> findResult.Row
                    
            End If
            
        Next

    End If

    wb.Close savechanges:=False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

パスワードつきExcel ファイルの無視する

ここでの処理で「If Err.Number = 1004 Then ～ 」というあまり見慣れないものがあると思います。

これはパスワードつきの Excel を開くときのエラーを無視するようにしています。

エラー1004コードを受け取った場合、Err.Clearとすることでエラーコードを削除します。

検索結果をシートに出力

最後に検索した結果が存在する場合、出力先のシート「search」に出力します。

このとき検索結果のセル位置が存在しない場合、出力しないように条件式を追加しています。

' 検索結果を出力
Private Sub writeSheet(ByRef myBook As Workbook, _
                        ByVal Path As String, _
                        ByVal buf As String, _
                        ByRef mysheet, _
                        ByRef findCell As Range)

    Dim outputSheet
    Dim outputCell
    
    Set outputSheet = myBook.Worksheets(SHEET_OUTPUT)
    
    outputCell = Split(Columns(findCell.Column).Address, "$")(2) & findCell.Column
    
    If outputCell <> "" Then
        
        outputSheet.Cells(nowRow, CELL_PRINT_COL) = buf
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 1) = Path
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 2) = mysheet.Name
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 3) = outputCell
        nowRow = nowRow + 1
    
    End If

End Sub

「サブフォルダ含むすべてのフォルダの Excel を文字検索するマクロ」の全ソース

最後にソースコード全部を紹介します。

また前章までの説明では「searchMacro()」がないと思いますが、これが今回のメイン処理です。

'=================================================================================
' フォルダ（サブフォルダ含む）内の Excel ブックの文字を検索するマクロ
'=================================================================================

Const SEARCH_WORD = "\*.xls*"
Const SHEET_OUTPUT = "search"
Const CELL_PRINT_COL = 1
Const CELL_PRINT_ROW = 6
Const CELL_SEARCH_WORD = "B3"

Dim nowRow As Long


' メイン処理
Sub searchMacro()

    Dim buf As String
    Dim Path As String
    Dim myBook As Workbook
    nowRow = CELL_PRINT_ROW
    Set myBook = ThisWorkbook
    
    If Range(CELL_SEARCH_WORD) <> "" Then
            
        Path = getFolderName()
        
        Call reset
        
        Call searchFile(Path, myBook)
        
        If nowRow = CELL_PRINT_ROW Then
            
            MsgBox "検索結果：「" & Range(CELL_SEARCH_WORD) & "」が含まれるファイルはありませんでした。"
            
        Else
        
            MsgBox "検索結果：「" & Range(CELL_SEARCH_WORD) & "」が含まれるファイルが" & nowRow - CELL_PRINT_ROW & "件ヒットしました！"
                
        End If
        
    
    Else
    
        MsgBox "検索ワードを入力してください"
    
    End If
    
End Sub

' シートの初期化
Private Sub reset()
    
    Application.ScreenUpdating = False
    
    Range(Cells(CELL_PRINT_ROW, CELL_PRINT_COL), Cells(Rows.Count, Columns.Count)).ClearContents
     
    Application.ScreenUpdating = True
    
End Sub


' 再帰的にファイルを検索
Private Sub searchFile(ByVal Path As String, ByRef myBook As Workbook)

    On Error Resume Next

    Dim buf As String, f As Object
    buf = Dir(Path & SEARCH_WORD)
    
    searchWord = Range(CELL_SEARCH_WORD)
        
    Do While buf <> ""
        
        Call grepExcel(searchWord, myBook, Path, buf)
        buf = Dir()
        
    Loop
    
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Path).SubFolders
            Call searchFile(f.Path, myBook)
        Next f
    End With

End Sub


' ダイアログでフォルダ名取得
Private Function getFolderName()

    Dim folderPath As Variant
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = 0 Then
            End
        End If
        folderPath = .SelectedItems(1)
    End With
    
    getFolderName = folderPath
  
End Function


' Excel ファイル内の文字検索
Private Sub grepExcel(ByVal searchWord, ByRef myBook As Workbook, ByVal Path As String, ByVal buf As String)

    Dim filePath
    Dim wb As Workbook
    Dim readSheet As Worksheet
    Dim Rng As Range
    Dim findResult

    fullPath = Path & "\" & buf

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    Set wb = Workbooks.Open(Filename:=fullPath, UpdateLinks:=0, ReadOnly:=True, IgnoreReadOnlyRecommended:=True, Password:="")
    
    If Err.Number = 1004 Then
        
        Err.Clear
    
    Else
    
        For Each mysheet In wb.Worksheets
            
            Set findResult = mysheet.Cells.Find(searchWord, LookAt:=xlPart)
            Dim findCell As Range
            Set findCell = findResult
            
            If Not (findCell Is Nothing) And Not (findResult Is Nothing) Then
            
                Do
                    If Not (findCell Is Nothing) And Not (findResult Is Nothing) Then
                        Call writeSheet(myBook, Path, buf, mysheet, findCell)
                        Set findCell = mysheet.Cells.FindNext(findCell)
                        If findCell Is Nothing Then
                            Exit For
                        End If
                    Else
                        Exit For
                    End If
                Loop While findCell.Row <> findResult.Row
                    
            End If
            
        Next

    End If

    wb.Close savechanges:=False
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub


' 検索結果を出力
Private Sub writeSheet(ByRef myBook As Workbook, _
                        ByVal Path As String, _
                        ByVal buf As String, _
                        ByRef mysheet, _
                        ByRef findCell As Range)

    Dim outputSheet
    Dim outputCell
    
    Set outputSheet = myBook.Worksheets(SHEET_OUTPUT)
    
    outputCell = Split(Columns(findCell.Column).Address, "$")(2) & findCell.Row
    
    If outputCell <> "" Then
        
        outputSheet.Cells(nowRow, CELL_PRINT_COL) = buf
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 1) = Path
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 2) = mysheet.Name
        outputSheet.Cells(nowRow, CELL_PRINT_COL + 3) = outputCell
        nowRow = nowRow + 1
    
    End If

End Sub

これで大量のフォルダの中から膨大な Excel ブックを検索することは日々はなくなると思います。