【VBA】同じフォルダ内のExcelファイルすべてを検索する : すきま研究所日誌

Excel VBAで複数のファイルにまたがるデータに対して、フォルダ内のExcelファイルを認識し、データ検索を行う場合の記述方法

フォルダ内検索VBA
VBAの詳細解説
例：フォルダ内全てのファイルから文字列検索

フォルダ内検索VBA

フォルダへのパスを渡し、フォルダ内の.xlsxという拡張子の付くExcelファイルをワイルドカードで指定し、フォルダ内すべてのExcelシートを検索します。

フォルダ内からファイルを開いて、全シートを検索対象として処理する部分のみ抜粋しています。このコードを使った処理の例は本記事末尾にあります。

VBA：

Sub FILE_SEARCH()'
    ' 検索フォルダパスの設定 '
    Const Path  As String = "C:\Users\User_Name\Path\"      ' Folder Path
    Dim buf     As String : buf = Dir(Path & "*.xlsx")
    If buf = "" Then
        MsgBox "存在しません"
        Exit Sub
    End If
    
    Dim ws      As Worksheet
    Do While buf <> "" ' ファイル処理 '
        Workbooks.Open Filename:=Path & buf, UpdateLinks:=0, ReadOnly:=True
        Workbooks(buf).Activate
        For Each ws In Worksheets ' Worksheet処理 '
             ' 処理を記述 '
        Next ws
        ActiveWorkbook.Close
        buf = Dir()
    Loop
End Sub

以下で記述の詳細について解説します。

VBAの詳細解説

コメントにほとんど記載している通りですが、2行～8行目で対象フォルダと、対象ファイルを定め、11行目～のループでフォルダ内のファイルを検索しています。

12行目で対象ファイルを開き、15行目に処理を記述し、17行目でファイルを閉じています。また、18行目の「buf = Dir()」でフォルダ内の次のファイルを取得しています。

フォルダパスとファイルの設定

検索したいファイルが存在するフォルダを以下の記述部で指定してます。

' 検索フォルダパスの設定 '
Const Path  As String = "C:\Users\User_Name\Path\"      ' Folder Path"
Dim buf     As String : buf = Dir(Path & "*.xlsx")
If buf = "" Then
    MsgBox "存在しません"
    Exit Sub
End If

ワイルドカードによって、xlsxファイルを指定してファイルを検索しています。

ファイルとデータの検索部

実際にファイル内のデータを処理するには、ファイルを開いて処理する必要があります。

Do While buf <> "" ' ファイル処理 '
    Workbooks.Open Filename:=Path & buf, UpdateLinks:=0, ReadOnly:=True
    Workbooks(buf).Activate
    For Each ws In Worksheets ' Worksheet処理 '
         ' 処理を記述 '
    Next ws
    ActiveWorkbook.Close
    buf = Dir()
Loop

変数bufで指定したファイルを「Workbooks.Open」で開き、内部のワークシートを精査しています。処理が終わったら、「ActiveWorkbook.Close」でファイルを閉じないと、ファイルが開きっぱなしになります。

エラーメッセージを停止

Excelファイルを開くと、以下のようなエラーメッセージが出てくることがあります。

このブックには更新できないリンクが1つ以上含まれています。

このブックには、ほかのデータソースへのリンクが含まれています。

これは、VBA上の処理でファイルを開いた時も同じで、毎回検索処理をするたびに出されて、手動で消すのも面倒なので、データリンクを明示的にオフにして、読み取り専用で開くようにしています。

Workbooks.Open Filename:=Path & buf, UpdateLinks:=0, ReadOnly:=True

「UpdateLinks:＝０」と「ReadOnly:＝True」が上記エラーが出ないようにしている部分です。

例：フォルダ内全てのファイルから文字列検索

検索用のスクリプトを作成して、フォルダ内のxlsxファイルの任意の名前のシート、任意の列のセルにターゲットとなる文字列が含まれるかどうか判別し、含まれる場合、ファイル名と行、列、セルの内容を書き出すVBA

VBA：

Sub FILE_SEARCH()
    Application.ScreenUpdating = False  ' 画面更新停止 '
    Application.ReferenceStyle = xlR1C1 ' 参照形式へ変更 '

    ' 検索フォルダパスの設定 '
    Const Path  As String = "C:\Users\User_Name\Path\"      ' Folder Path"
    Dim buf     As String : buf = Dir(Path & "*.xlsx")
    If buf = "" Then
        MsgBox "存在しません"
        Exit Sub
    End If
    
    ThisWorkbook.Activate
    Dim sheet_name  As String : sheet_name  = Worksheets("worksheet_name").Cells(4, 3)  ' 設定：検索Sheet名 '
    Dim col0        As Long   : col0        = Worksheets("worksheet_name").Cells(5, 3)  ' 設定：検索列 '
    Dim target      As String : target      = Worksheets("worksheet_name").Cells(2, 3)  ' 設定：検索ターゲット文字列 '

    Dim ws      As Worksheet
    Dim max_row As Long     ' 最大行 '
    Dim row0    As Long     ' 行 '

    Dim w_row    As Long : w_row = 10　' 初期記入行 '
    Dim Myarray(4) As Variant            ' 配列 '

    Do While buf <> ""
        Workbooks.Open Filename:=Path & buf, UpdateLinks:=0, ReadOnly:=True
        Workbooks(buf).Activate
        For Each ws In Worksheets
            If (ws.Name = sheet_name) Then ' 対象sheet有無 '
                max_row = Worksheets(sheet_name).Cells(Rows.Count, col0).End(xlUp).Row ' 最大行取得 '
                For row0 = 1 To max_row
                    If (InStr(Worksheets(sheet_name).Cells(row0, col0), target) <> 0) Then ' 文字列検索 '
                        ThisWorkbook.Activate
                        Myarray(0) = buf
                        Myarray(1) = row0 & " 行"
                        Myarray(2) = col0 & " 列"
                        Myarray(3) = Workbooks(buf).Worksheets(sheet_name).Cells(row0, col0)
                        Worksheets("worksheet_name").Range(Cells(w_row, 3), Cells(w_row, 6)) = Myarray
                        w_row = w_row + 1
                        Workbooks(buf).Activate
                    End If
                Next row0
            End If
        Next ws
        ActiveWorkbook.Close
        buf = Dir()
    Loop
    Application.ScreenUpdating = True ' 画面更新再開 '
End Sub

以上