VBA｜フォルダに含まれる全ブック（エクセルファイル）の文字検索する

ある任意のフォルダに含まれる全エクセルブック（エクセルファイル）に対して、任意の文字を検索し、該当したファイルの一覧を表示するVBAを紹介します。

このマクロの特徴は、

• 任意のフォルダをインプットボックスで指定できる
• 検索対象の任意の文字をインプットボックスで指定できる
• 任意のフォルダ内にある全エクセルブックを対象に文字検索を実施する
• 任意のフォルダ内にあるサブフォルダをすべて抽出し、その中のエクセルブックに対しても検索を実施する
• サブフォルダは複数の階層になっていてもすべてを抽出する
• 検索対象の任意の文字が含まれているエクセルブックをすべて抽出し、一覧表を作成する
• 一覧表示には、抽出した　ファイル名、ワークシート名、検索文字のセル番号（１ファイルにつき１つ）、最終更新日、ファイルパス　が表示される

マクロ実行前の準備

1. Microsoft Excel を起動します。
2. ブックを開きます。
3. 「ファイル」をクリックしてから、「オプション」をクリックします。
4. ナビゲーション・ウィンドウで、「セキュリティー・センター」を選択します。
5. 「セキュリティー・センターの設定」をクリックします。
6. ナビゲーション・ウィンドウで、「マクロの設定」を選択します。
7. 「VBA プロジェクト・オブジェクト・モデルへのアクセスを信頼する」チェック・ボックスがオンになっていることを確認します。
8. 「OK」をクリックします。

 

それと、「文字検索.xlsm」というファイル名のエクセルファイルを準備してください。

それと、VBAの画面で、 ツール→参照設定→microsoft scripting runtime にチェックをしてください。

フォルダに含まれる全ブック（エクセルファイル）の文字検索VBAサンプルコード

 

Dim inp_moji As String
Dim write_cell_count As Long

Sub ファイル一覧取得()

       
    Dim objFSO As FileSystemObject
    Dim strDir As String
    Dim i As Long
    'Dim Fso As Object
    Dim dig As FileDialog
    
    
    Application.ScreenUpdating = False
    
    write_cell_count = 4
    
    
    'フォルダ選択
    Set dig = Application.FileDialog(msoFileDialogFolderPicker)
    If dig.Show = False Then
        Exit Sub
    End If
 
    strDir = dig.SelectedItems(1)

    
    'FileSystemObjectのインスタンスの生成
    Set objFSO = New FileSystemObject
    'フォルダの存在確認
    If Not objFSO.FolderExists(strDir) Then
        MsgBox ("指定のフォルダは存在しません")
        Exit Sub
    End If
    
    '検索文字の取得
    inp_moji = GetMoji()
    Cells(1, 1) = "検索文字"
    Cells(2, 1) = inp_moji
    
    Cells(4, 1) = "ファイル名"
    Cells(4, 2) = "シート名"
    Cells(4, 3) = "セル番号"
    Cells(4, 4) = "最終更新日"
    Cells(4, 5) = "アドレス"
    
    
    i = 5 '開始行位置
    '再帰処理モジュールのコール
    Call GetDirFiles(objFSO.GetFolder(strDir), i)
    
    'オブジェクトの解放
    Set objFSO = Nothing
    
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
End Sub


Sub GetDirFiles(ByVal objFolder As Folder, ByRef i As Long)
    Dim objFolderSub As Folder
    Dim objfile As File
    'サブフォルダの取得
    For Each objFolderSub In objFolder.SubFolders
        'Cells(i, 2) = objFolderSub.Name
        i = i + 1
        Call GetDirFiles(objFolderSub, i)
    Next
    'ファイルの取得
    For Each objfile In objFolder.Files
            i = i + 1
            
            Call Opfile(objfile)   '''ファイルオープンのプロシージャを呼び出し
            
    Next
    
    
    'オブジェクトの解放
    Set objFolderSub = Nothing
    Set objfile = Nothing
End Sub

Function GetMoji() As String

    '文字検索入力
    
    GetMoji = InputBox(prompt:="検索文字を入力してください", _
                     Title:="検索文字入力")
    

End Function


Sub Opfile(ByVal wb As Variant)

'文字検索
    Dim kensaku_moji_r As Range
    Dim find_cell As Range
    Dim next_find_cell As Range
    Dim n As Long
    Dim wb_book As Workbook
 
 Set wb_book = Workbooks.Open(wb)


For n = 1 To Worksheets.Count


 Set find_cell = wb_book.Worksheets(n).UsedRange.Find( _
     what:=inp_moji, _
     MatchCase:=False, _
     matchbyte:=False, _
     lookat:=xlPart)
     
 If Not (find_cell Is Nothing) Then
     
 write_cell_count = write_cell_count + 1
 
 With Workbooks("文字検索.xlsm").Worksheets(1)
   
   .Cells(write_cell_count, 1) = wb_book.Name
    
   .Cells(write_cell_count, 2) = wb_book.Worksheets(n).Name
   
    .Cells(write_cell_count, 3) = find_cell.Address
    
    .Cells(write_cell_count, 4) = wb.DateLastModified
 
    .Cells(write_cell_count, 5) = wb_book.FullName
 End With
 
 On Error GoTo 0
 
 End If
 Next n
 
 Application.DisplayAlerts = False
 Call wb_book.Close(savechanges:=False)
 Application.DisplayAlerts = True
 

End Sub