【VBA】複数のブックに対する検索(フォルダ内のブックをすべて検索)

Excelで資料を作成しているとき、同じような文言をすべて変更したい場合があります。

「プロジェクトの名前が変わってしまったので、今まで作った資料の中にあるプロジェクト名をすべて変更しなければいけない」とかです。（実際にそんな状況になったらキレそうですがｗ）

それを補助するために、複数のブックに対して検索処理を行うVBAプログラムを作成しました。

「複数とは、どれを検索すればいいのか？」という情報をVBAに与えなければいけないのですが、今回は特定のフォルダ内にあるファイルをすべて検索するというプログラムにしました。

作成したプログラムについて紹介していこうと思います。

今回作成したプログラムを含むExcelは下記からダウンロードもできます。

https://vbaexcel.slavesystems.com/product/%E8%A4%87%E6%95%B0%E3%83%96%E3%83%83%E3%82%AF%E6%A4%9C%E7%B4%A2%E3%82%B5%E3%83%B3%E3%83%97%E3%83%AB.xlsm

フォルダ内のブックをすべて検索するプログラム

早速ですがソースは以下になります。

'プログラムで使用する定数
Const RESULT_SHEET_NAME As String = "結果"  '検索結果を記載するシート
Const COL_FILE As Integer = 1  '検索結果のファイル名の列番号
Const COL_SHEET As Integer = 2  '検索結果のシート名の列番号
Const COL_CELL As Integer = 3  '検索結果のセルアドレスの列番号
Const COL_VALUE As Integer = 4  '検索結果の設定値の列番号
Const ROW_START As Long = 2 '検索結果を記載し始める列

Const KEYWORD As String = "テスト" '検索対象の文字列
Const TARGET_FOLDER As String = "C:\Users\namek\OneDrive\デスクトップ\test" '検索対象Excelがあるフォルダ

'メイン処理
Public Sub search_multi_book()
    '大量に処理する場合は、Application.ScreenUpdating = Falseを使って画面描画を止めた方が良い（今回はスキップ）

    '検索結果を記載するシートを変数に格納
    Dim result_sheet As Worksheet
    Set result_sheet = ThisWorkbook.Worksheets(RESULT_SHEET_NAME)
    
    'フォルダを変数に格納
    Dim obj_folder As Object
    Set obj_folder = get_folder(TARGET_FOLDER)
    If obj_folder Is Nothing Then
        'フォルダが取得できない場合はメッセージを出力して終了
        Exit Sub
    End If
    
    '前回の検索結果をクリア
    result_sheet.Rows(CStr(ROW_START) & ":1048576").Clear
    
    'メイン処理へ
    Call search_folder(result_sheet, obj_folder, ROW_START)

End Sub

'文字列をもとにフォルダを取得する
Private Function get_folder(path As String) As Object
    On Error GoTo errProc
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Right(TARGET_FOLDER, 1) <> "\ " Then
        'フォルダの末尾が\でないなら補完する
        Set get_folder = fso.getFolder(TARGET_FOLDER + "\")
    Else
        Set get_folder = fso.getFolder(TARGET_FOLDER)
    End If
    Exit Function
errProc:
    'フォルダが取得できない場合はメッセージを出力して終了
    MsgBox "エラーが発生しました。フォルダが取得できません。"
    Set get_folder = Nothing
End Function


'フォルダ内を検索してファイルの一覧を取得する処理
Private Sub search_folder(result_sheet As Worksheet, folder As Object, ByRef current_row As Long)
    
    Dim file As Object
    For Each file In folder.Files
        '拡張子を取得
        Dim extension As String
        extension = Mid(file.Name, InStrRev(file.Name, ".") + 1)
        
        If extension = "xls" Or extension = "xlsx" Or extension = "xlsm" Then
            'xls、xlsx、xlsmの時だけ処理する
            Dim wb As Workbook
            'ワークブックを開く
            Set wb = Workbooks.Open(file.path, ReadOnly:=True)
            Call search_workbook(result_sheet, wb, current_row)
            'ワークブックを閉じる
            wb.Close
        End If
    Next
End Sub

'ワークブック内を検索して検索結果に表示する処理
Private Sub search_workbook(result_sheet As Worksheet, wb As Workbook, ByRef current_row As Long)
    Dim sh As Worksheet
    
    For Each sh In wb.Worksheets
        '各シートを順番に処理する
        Dim result_cell As Range '検索結果（ヒットしたセル）を格納するセル
        Dim first_cell As Range '最初にヒットしたセル
        
        ' 検索を実行
        Set result_cell = sh.Cells.Find(What:=KEYWORD, LookAt:=xlPart)
        If result_cell Is Nothing Then
            '見つからない場合、次のシートへ
            GoTo next_sheet
        Else
            Set first_cell = result_cell
            '結果を記載してく
            result_sheet.Cells(current_row, COL_FILE).Value = wb.path
            result_sheet.Cells(current_row, COL_SHEET).Value = sh.Name
            result_sheet.Cells(current_row, COL_CELL).Value = Replace(first_cell.Address, "$", "")
            result_sheet.Cells(current_row, COL_VALUE).Value = first_cell.Value
            current_row = current_row + 1
        End If
        Do
            '検索結果がなくなるまでループして検索
            Set result_cell = sh.Cells.FindNext(result_cell)
            If result_cell.Address = first_cell.Address Then
                '最初の結果と同じになったら終了
                Exit Do
            Else
                '結果を記載してく
                result_sheet.Cells(current_row, COL_FILE).Value = wb.path
                result_sheet.Cells(current_row, COL_SHEET).Value = sh.Name
                result_sheet.Cells(current_row, COL_CELL).Value = Replace(result_cell.Address, "$", "")
                result_sheet.Cells(current_row, COL_VALUE).Value = result_cell.Value
                current_row = current_row + 1
            End If
        Loop
next_sheet:
    Next
End Sub

冒頭で記載している下記箇所が検索する文字列になります。（サンプルだと「テスト」を検索している）

Const KEYWORD As String = “テスト”

下記箇所が検索対象フォルダのパスになります。

Const TARGET_FOLDER As String = “C:\Users\namek\OneDrive\デスクトップ\test”

実際に使用するには、キーワードやフォルダをInputBoxなどで入力させる or シートに記載してもらう方が便利だと思います。

冒頭に記載したサンプルプログラムの方ではInputBox方式で実装してみました。

VBAを実行すると「結果」というシートに検索結果が記載されます。結果というシートはあらかじめ準備されている前提としています。

↑「結果」というシートにヒットした個所のファイル名、シート名、セルアドレス、セルの値が一覧で記載されていく

あと面倒なパターンとして考えられるのが、検索対象のエクセルと同名ファイルを開いていた場合ですね。

同名ファイルを開いていたら、「新しくファイルを開かずにそのファイルを検索する」という回避方法もありますが、検索したかったファイルではないファイルを開いていたという可能性もあるので、今回ではそのままエラーにしています。

サブフォルダも検索対象にする

フォルダ構成が複雑でサブフォルダの中身も検索対象にしなくてはいけない場合もあるかと思います。

それに対応させるには以下の関数を変更します。

'プログラムで使用する定数
Const RESULT_SHEET_NAME As String = "結果"  '検索結果を記載するシート
Const COL_FILE As Integer = 1  '検索結果のファイル名の列番号
Const COL_SHEET As Integer = 2  '検索結果のシート名の列番号
Const COL_CELL As Integer = 3  '検索結果のセルアドレスの列番号
Const COL_VALUE As Integer = 4  '検索結果の設定値の列番号
Const ROW_START As Long = 2 '検索結果を記載し始める列

Const KEYWORD As String = "テスト" '検索対象の文字列
Const TARGET_FOLDER As String = "C:\Users\namek\OneDrive\デスクトップ\test" '検索対象Excelがあるフォルダ

'メイン処理
Public Sub search_multi_book()
    '大量に処理する場合は、Application.ScreenUpdating = Falseを使って画面描画を止めた方が良い（今回はスキップ）

    '検索結果を記載するシートを変数に格納
    Dim result_sheet As Worksheet
    Set result_sheet = ThisWorkbook.Worksheets(RESULT_SHEET_NAME)
    
    'フォルダを変数に格納
    Dim obj_folder As Object
    Set obj_folder = get_folder(TARGET_FOLDER)
    If obj_folder Is Nothing Then
        'フォルダが取得できない場合はメッセージを出力して終了
        Exit Sub
    End If
    
    '前回の検索結果をクリア
    result_sheet.Rows(CStr(ROW_START) & ":1048576").Clear
    
    'メイン処理へ
    Call search_folder(result_sheet, obj_folder, ROW_START)

End Sub

'文字列をもとにフォルダを取得する
Private Function get_folder(path As String) As Object
    On Error GoTo errProc
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Right(TARGET_FOLDER, 1) <> "\ " Then
        'フォルダの末尾が\でないなら補完する
        Set get_folder = fso.getFolder(TARGET_FOLDER + "\")
    Else
        Set get_folder = fso.getFolder(TARGET_FOLDER)
    End If
    Exit Function
errProc:
    'フォルダが取得できない場合はメッセージを出力して終了
    MsgBox "エラーが発生しました。フォルダが取得できません。"
    Set get_folder = Nothing
End Function


'フォルダ内を検索してファイルの一覧を取得する処理
Private Sub search_folder(result_sheet As Worksheet, folder As Object, ByRef current_row As Long)
    
    'サブフォルダに対して再帰的に処理を実施する
    Dim sub_folder  As Object
    For Each sub_folder In folder.SubFolders
        Call search_folder(result_sheet, sub_folder, current_row)
    Next
    
    Dim file As Object
    For Each file In folder.Files
        '拡張子を取得
        Dim extension As String
        extension = Mid(file.Name, InStrRev(file.Name, ".") + 1)
        
        If extension = "xls" Or extension = "xlsx" Or extension = "xlsm" Then
            'xls、xlsx、xlsmの時だけ処理する
            Dim wb As Workbook
            'ワークブックを開く
            Set wb = Workbooks.Open(file.path, ReadOnly:=True)
            Call search_workbook(result_sheet, wb, current_row)
            'ワークブックを閉じる
            wb.Close
        End If
    Next
End Sub

'ワークブック内を検索して検索結果に表示する処理
Private Sub search_workbook(result_sheet As Worksheet, wb As Workbook, ByRef current_row As Long)
    Dim sh As Worksheet
    
    For Each sh In wb.Worksheets
        '各シートを順番に処理する
        Dim result_cell As Range '検索結果（ヒットしたセル）を格納するセル
        Dim first_cell As Range '最初にヒットしたセル
        
        ' 検索を実行
        Set result_cell = sh.Cells.Find(What:=KEYWORD, LookAt:=xlPart)
        If result_cell Is Nothing Then
            '見つからない場合、次のシートへ
            GoTo next_sheet
        Else
            Set first_cell = result_cell
            '結果を記載してく
            result_sheet.Cells(current_row, COL_FILE).Value = wb.path
            result_sheet.Cells(current_row, COL_SHEET).Value = sh.Name
            result_sheet.Cells(current_row, COL_CELL).Value = Replace(first_cell.Address, "$", "")
            result_sheet.Cells(current_row, COL_VALUE).Value = first_cell.Value
            current_row = current_row + 1
        End If
        Do
            '検索結果がなくなるまでループして検索
            Set result_cell = sh.Cells.FindNext(result_cell)
            If result_cell.Address = first_cell.Address Then
                '最初の結果と同じになったら終了
                Exit Do
            Else
                '結果を記載してく
                result_sheet.Cells(current_row, COL_FILE).Value = wb.path
                result_sheet.Cells(current_row, COL_SHEET).Value = sh.Name
                result_sheet.Cells(current_row, COL_CELL).Value = Replace(result_cell.Address, "$", "")
                result_sheet.Cells(current_row, COL_VALUE).Value = result_cell.Value
                current_row = current_row + 1
            End If
        Loop
next_sheet:
    Next
End Sub

最初のソースからの変更点ですが、以下になります。もしサブフォルダがあればループさせて再帰呼び出ししています。

部分一致ではなく完全一致で検索する

完全一致とは、セルの値が完全に同じものだけを検索するということです。例えば検索キーワードが「テスト」、セルの値が「テストです」の場合は検索でヒットしません。

逆に部分一致とは、一部でもキーワードが含まれていれば検索でヒットしたとみなします。

上記で作成したプログラムでは部分一致となっていました。これを完全一致で検索するには以下のように修正します。

'プログラムで使用する定数
Const RESULT_SHEET_NAME As String = "結果"  '検索結果を記載するシート
Const COL_FILE As Integer = 1  '検索結果のファイル名の列番号
Const COL_SHEET As Integer = 2  '検索結果のシート名の列番号
Const COL_CELL As Integer = 3  '検索結果のセルアドレスの列番号
Const COL_VALUE As Integer = 4  '検索結果の設定値の列番号
Const ROW_START As Long = 2 '検索結果を記載し始める列

Const KEYWORD As String = "テスト" '検索対象の文字列
Const TARGET_FOLDER As String = "C:\Users\namek\OneDrive\デスクトップ\test" '検索対象Excelがあるフォルダ

'メイン処理
Public Sub search_multi_book()
    '大量に処理する場合は、Application.ScreenUpdating = Falseを使って画面描画を止めた方が良い（今回はスキップ）

    '検索結果を記載するシートを変数に格納
    Dim result_sheet As Worksheet
    Set result_sheet = ThisWorkbook.Worksheets(RESULT_SHEET_NAME)
    
    'フォルダを変数に格納
    Dim obj_folder As Object
    Set obj_folder = get_folder(TARGET_FOLDER)
    If obj_folder Is Nothing Then
        'フォルダが取得できない場合はメッセージを出力して終了
        Exit Sub
    End If
    
    '前回の検索結果をクリア
    result_sheet.Rows(CStr(ROW_START) & ":1048576").Clear
    
    'メイン処理へ
    Call search_folder(result_sheet, obj_folder, ROW_START)

End Sub

'文字列をもとにフォルダを取得する
Private Function get_folder(path As String) As Object
    On Error GoTo errProc
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Right(TARGET_FOLDER, 1) <> "\ " Then
        'フォルダの末尾が\でないなら補完する
        Set get_folder = fso.getFolder(TARGET_FOLDER + "\")
    Else
        Set get_folder = fso.getFolder(TARGET_FOLDER)
    End If
    Exit Function
errProc:
    'フォルダが取得できない場合はメッセージを出力して終了
    MsgBox "エラーが発生しました。フォルダが取得できません。"
    Set get_folder = Nothing
End Function


'フォルダ内を検索してファイルの一覧を取得する処理
Private Sub search_folder(result_sheet As Worksheet, folder As Object, ByRef current_row As Long)
    Dim file As Object
    For Each file In folder.Files
        '拡張子を取得
        Dim extension As String
        extension = Mid(file.Name, InStrRev(file.Name, ".") + 1)
        
        If extension = "xls" Or extension = "xlsx" Or extension = "xlsm" Then
            'xls、xlsx、xlsmの時だけ処理する
            Dim wb As Workbook
            'ワークブックを開く
            Set wb = Workbooks.Open(file.path, ReadOnly:=True)
            Call search_workbook(result_sheet, wb, current_row)
            'ワークブックを閉じる
            wb.Close
        End If
    Next
End Sub

'ワークブック内を検索して検索結果に表示する処理
Private Sub search_workbook(result_sheet As Worksheet, wb As Workbook, ByRef current_row As Long)
    Dim sh As Worksheet
    
    For Each sh In wb.Worksheets
        '各シートを順番に処理する
        Dim result_cell As Range '検索結果（ヒットしたセル）を格納するセル
        Dim first_cell As Range '最初にヒットしたセル
        
        ' 検索を実行
        Set result_cell = sh.Cells.Find(What:=KEYWORD, LookAt:=xlPart)
        If result_cell Is Nothing Then
            '見つからない場合、次のシートへ
            GoTo next_sheet
        Else
            Set first_cell = result_cell
            '結果を記載してく
            result_sheet.Cells(current_row, COL_FILE).Value = wb.path
            result_sheet.Cells(current_row, COL_SHEET).Value = sh.Name
            result_sheet.Cells(current_row, COL_CELL).Value = Replace(first_cell.Address, "$", "")
            result_sheet.Cells(current_row, COL_VALUE).Value = first_cell.Value
            current_row = current_row + 1
        End If
        Do
            '検索結果がなくなるまでループして検索
            Set result_cell = sh.Cells.FindNext(result_cell)
            If result_cell.Address = first_cell.Address Then
                '最初の結果と同じになったら終了
                Exit Do
            Else
                '結果を記載してく
                result_sheet.Cells(current_row, COL_FILE).Value = wb.path
                result_sheet.Cells(current_row, COL_SHEET).Value = sh.Name
                result_sheet.Cells(current_row, COL_CELL).Value = Replace(result_cell.Address, "$", "")
                result_sheet.Cells(current_row, COL_VALUE).Value = result_cell.Value
                current_row = current_row + 1
            End If
        Loop
next_sheet:
    Next
End Sub

ソース長いのですが変えたところは以下の部分だけです。