指定フォルダの全ブック対象に一括検索2021.05.10 更新：2025.11.22
指定フォルダの全ブック・全シートを対象に、任意の文字列を一括検索するマクロです。
マクロ「searchAllBooksForAnyString」を実行すると、フォルダ参照ダイアログが表示されます。
フォルダを選択すると、そのフォルダ内の、全てのExcelブックの全シートを対象に、検索を開始します。
検索の結果は、新しいブックにまとめて出力されます（下図参照）。
検索する文字列は、複数の指定が可能です。
【お薦め】マクロ・プロシージャを管理する無料のツール！
Excelマクロ管理ツール
Excelマクロ管理ツール
サンプルコード
コードの貼り付け場所 VBAコードをカラーで印刷・Web掲載するためのツールはこちら
'-------------------------------------------------------- ' 指定フォルダ内の全てのブックから任意の文字列を検索する '-------------------------------------------------------- ' ※非表示のセルは検索対象外です '［作成日］2021.05.10 ［更新日］2025.11.22 ' https://excel.syogyoumujou.com/vba/find_allbooks.html '-------------------------------------------------------- Sub searchAllBooksForAnyString() '-------------------------------- ' 検索する文字列を配列として設定 '-------------------------------- Dim varArray As Variant varArray = Array("奈良市", "鎌倉市") ' 検索文字列 '-------------------------------- ' フォルダの選択 '-------------------------------- Dim strFolderPath As String With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then strFolderPath = .SelectedItems(1) End With If Len(strFolderPath) = 0 Then Exit Sub '-------------------------------- ' フォルダの存在確認 '-------------------------------- If Dir(strFolderPath, vbDirectory) = "" Then MsgBox "対象のフォルダが見つかりません", vbExclamation, "終了します" Exit Sub End If '-------------------------------- ' フォルダ内ブックを検索 '-------------------------------- Dim strFileName As String strFolderPath = strFolderPath & Application.PathSeparator ' フォルダパスに区切り文字追加 strFileName = Dir(strFolderPath & "*.xls?") ' フォルダからExcelブックを検索 If strFileName = "" Then ' ブックのパスを取得できなければ終了 MsgBox "指定フォルダ内にExcelブックが見つかりません", vbExclamation, "終了します" Exit Sub End If ' ファイルパスをコレクションに追加 Dim colFilePath As New Collection Do colFilePath.Add strFolderPath & strFileName, CStr(colFilePath.Count + 1) strFileName = Dir() Loop Until strFileName = "" Application.ScreenUpdating = False ' 画面更新無効 Application.EnableEvents = False ' イベント無効 '-------------------------------- ' 新規ブック追加・見出し設定 '-------------------------------- Dim shtWrite As Worksheet ' 書き込みシート Set shtWrite = Workbooks.Add.Worksheets(1) shtWrite.Range("A1:B1").Value = Array("検索日時", Now()) shtWrite.Range("A3:B3").Value = Array("検索値", Join$(varArray, ",")) shtWrite.Range("A5:D5").Value = Array("ブック名", "シート名", "セルアドレス", "値") shtWrite.Range("A1:A3,A5:D5").Interior.Color = RGB(217, 217, 217) '-------------------------------- ' ブック内から文字列を検索 '-------------------------------- Dim i As Long Dim wbkTarget As Workbook Dim shtTarget As Worksheet Dim rngTarget As Range Dim rng As Range Dim varWhat As Variant Dim lngCount As Long On Error Resume Next For i = 1 To colFilePath.Count ' ブックを開く Set wbkTarget = Workbooks.Open(colFilePath.Item(CStr(i))) If Not wbkTarget Is Nothing Then '各シートで検索を実行 For Each shtTarget In wbkTarget.Worksheets For Each varWhat In varArray '《対象セル範囲から任意の文字列を検索》 Set rngTarget = findTargetCell(shtTarget.Cells, varWhat) ' 検索に一致するセルが存在する場合は新規ブックに情報を書き込み If Not rngTarget Is Nothing Then For Each rng In rngTarget With shtWrite.Cells(6 + lngCount, "A").Resize(1, 4) .Value = Array(wbkTarget.Name, _ shtTarget.Name, _ rng.Address(False, False), _ rng.Value) lngCount = lngCount + 1 End With Next End If Next Next ' 開いたブックを保存せずに閉じる wbkTarget.Close SaveChanges:=False End If Set wbkTarget = Nothing Next On Error GoTo 0 '-------------------------------- ' 検索値が見つからなければ終了 '-------------------------------- If lngCount = 0 Then shtWrite.Parent.Close SaveChanges:=False MsgBox "検索値は見つかりませんでした", vbInformation GoTo LBL_FINALLY End If '-------------------------------- ' 新規ブックレイアウト調整 '-------------------------------- shtWrite.Columns("A:C").AutoFit ' A～C列を自動調整する shtWrite.Columns("D:D").ColumnWidth = 100 shtWrite.Range("A2:B2").Value = Array("フォルダ", Left$(strFolderPath, Len(strFolderPath) - 1)) MsgBox "検索終了", vbInformation LBL_FINALLY: Application.EnableEvents = True Application.ScreenUpdating = True End Sub
'-------------------------------------------------------------------------------- ' 対象セル範囲から任意の文字列を検索 '-------------------------------------------------------------------------------- '［引数］ ' rngTarget ：対象セル範囲 ' What ：検索する文字列 ' LookIn ：情報種類 値：xlValues[既定] 数式：xlFormulas コメント文：xlComments ' LookAt ：一致の種類 部分一致：xlPart[既定] 全体一致：xlWhole ' SearchOrder ：検索方法 1行ごと検索：xlByRows[既定] 1列ごと検索：xlByColumns ' SearchDirection：検索順 一致する次の値：xlNext[既定] 一致する前の値：xlPrevious ' MatchCase ：大文字・小文字の区別 区別する：True 区別しない：False[既定] ' MatchByte ：全角・半角の区別 区別する：True 区別しない：False[既定] '［戻り値］ ' 検索に一致したセルの集合 検索値がない場合はNothing '［作成日］2023.12.19 ［更新日］2025.11.22 ' https://excel.syogyoumujou.com/vba/find_allbooks.html '-------------------------------------------------------------------------------- Function findTargetCell(ByRef rngTarget As Range, _ ByVal What As String, _ Optional ByVal LookIn As XlFindLookIn = xlValues, _ Optional ByVal LookAt As XlLookAt = xlPart, _ Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _ Optional ByVal SearchDirection As XlSearchDirection = xlNext, _ Optional ByVal MatchCase As Boolean = False, _ Optional ByVal MatchByte As Boolean = False) As Range ' 検索セル範囲を最適化 Set rngTarget = Intersect(rngTarget, rngTarget.Worksheet.UsedRange) If rngTarget Is Nothing Then Exit Function ' 検索実行 Dim rngFind As Range Set rngFind = rngTarget.Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte) ' 検索に一致のセルがない場合 If rngFind Is Nothing Then ' ※ 結合セルで検索に一致しないケースがあるため その対策処理 If SearchOrder = xlByRows Then SearchOrder = xlByColumns Else SearchOrder = xlByRows Set rngFind = rngTarget.Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte) If rngFind Is Nothing Then Exit Function End If Dim strAddress As String Dim rngUnion As Range strAddress = rngFind.Address '最初に検索一致したセルのアドレスを取得 Set rngUnion = rngFind Do Set rngUnion = Union(rngUnion, rngFind) 'セルを集合 Set rngFind = rngTarget.FindNext(rngFind) '次の一致セルを検索 If rngFind Is Nothing Then Exit Do Loop Until strAddress = rngFind.Address 'セルアドレスが最初のセルと同じ場合はループを抜ける Set findTargetCell = rngUnion End Function
「検索文字列」
検索する文字列です。検索文字列の追加は、次の例を参考にしてください。
例：Array("奈良市", "鎌倉市") → Array("奈良市", "鎌倉市", "仙台市", "福岡市")
サンプルコード 22025.11.22
指定したフォルダとその配下フォルダ内の全てのExcelファイルを検索対象とするサンプルコードです。
'--------------------------------------------------------------- ' 指定フォルダ・配下フォルダ内の全ブックから任意の文字列を検索 '--------------------------------------------------------------- ' ※非表示のセルは検索対象外です '［作成日］2025.11.22 ' https://excel.syogyoumujou.com/vba/find_allbooks.html#code2 '--------------------------------------------------------------- Sub 指定フォルダ配下フォルダの全ブックから任意の文字列を検索() '-------------------------------- ' 検索する文字列を配列として設定 '-------------------------------- Dim varArray As Variant varArray = Array("神奈川県", "千葉県") ' 検索文字列 '-------------------------------- ' 指定・配下の全フォルダパス取得 '-------------------------------- Dim colFolderPath As New Collection '《指定フォルダ・配下フォルダのパス取得》 ' ** 引数1：基準とするフォルダパス ' ** 引数2：フォルダパスを追加するコレクション ' 戻り値： 0：成功 ' -1：フォルダ選択ダイアログボックスで「キャンセル」を選択 If getSubordinateFolders("", colFolderPath) = -1 Then Exit Sub ' 基準フォルダパス Dim strFolderPath As String strFolderPath = colFolderPath.Item(CStr(1)) '-------------------------------- ' 各フォルダのExcelパスを取得 '-------------------------------- Dim varFolderPath As Variant Dim strTarget As String Dim colFilePath As New Collection For Each varFolderPath In colFolderPath ' フォルダパスにフォルダ区切り文字追加 varFolderPath = varFolderPath & Application.PathSeparator ' フォルダ内のExcelファイルを検索 strTarget = Dir(varFolderPath & "*.xls?") Do Until strTarget = "" ' ファイルがなければ抜ける ' ファイルパスをコレクションに追加 colFilePath.Add varFolderPath & strTarget, CStr(colFilePath.Count + 1) ' 次のファイル検索 strTarget = Dir() Loop Next ' ファイルパス数が 0 の場合は終了 If colFilePath.Count = 0 Then MsgBox "Excelファイルは見つかりませんでした", vbInformation Exit Sub End If ' -- 検索・出力 -- Application.ScreenUpdating = False ' 画面更新無効 Application.EnableEvents = False ' イベント無効 '-------------------------------- ' 新規ブック追加・見出し設定 '-------------------------------- Dim shtWrite As Worksheet ' 書き込みシート Set shtWrite = Workbooks.Add.Worksheets(1) shtWrite.Range("A1:B1").Value = Array("検索日時", Now()) 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) '-------------------------------- ' ブック内から文字列を検索 '-------------------------------- Dim i As Long Dim wbkTarget As Workbook Dim shtTarget As Worksheet Dim rngTarget As Range Dim rng As Range Dim varWhat As Variant Dim lngCount As Long On Error Resume Next For i = 1 To colFilePath.Count ' フォルダ内のブックを開く Set wbkTarget = Workbooks.Open(colFilePath.Item(CStr(i))) If Not wbkTarget Is Nothing Then '-------------------------------- 'ブックの各シートで検索を実行 '-------------------------------- For Each shtTarget In wbkTarget.Worksheets For Each varWhat In varArray '《対象セル範囲から任意の文字列を検索》 Set rngTarget = findTargetCell(shtTarget.Cells, varWhat) ' 検索に一致するセルが存在する場合は新規ブックに情報を書き込み If Not rngTarget Is Nothing Then For Each rng In rngTarget With shtWrite.Cells(6 + lngCount, "A").Resize(1, 5) .Value = Array(wbkTarget.Name, _ shtTarget.Name, _ rng.Address(False, False), _ rng.Value, _ Mid$(colFilePath.Item(CStr(i)), Len(strFolderPath) + 1)) lngCount = lngCount + 1 End With Next End If Next Next ' 開いたブックを保存せずに閉じる wbkTarget.Close SaveChanges:=False End If Set wbkTarget = Nothing Next On Error GoTo 0 '-------------------------------- ' 検索値が見つからなければ終了 '-------------------------------- If lngCount = 0 Then shtWrite.Parent.Close SaveChanges:=False MsgBox "検索値は見つかりませんでした", vbInformation GoTo LBL_FINALLY End If '-------------------------------- ' 新規ブックレイアウト調整 '-------------------------------- shtWrite.Columns("A:C").AutoFit ' A～C列を自動調整する shtWrite.Columns("D:E").ColumnWidth = 60 shtWrite.Range("A2:B2").Value = Array("基準フォルダ", strFolderPath) MsgBox "検索終了", vbInformation LBL_FINALLY: Application.EnableEvents = True Application.ScreenUpdating = True End Sub
'-------------------------------------------------------------------------------- ' 指定フォルダ・配下フォルダのパス取得（再帰関数） '-------------------------------------------------------------------------------- '［引数］ ' FolderPath ：対象フォルダパス ' colFolderPath：フォルダパスを追加するコレクションオブジェクト '［戻り値］ ' 0：成功 ' -1：フォルダ選択ダイアログボックスで「キャンセル」をクリック '［作成日］2023.07.07 ［更新日］2025.11.22 ' https://excel.syogyoumujou.com/vba/find_allbooks.html '-------------------------------------------------------------------------------- Function getSubordinateFolders(ByVal FolderPath As String, _ ByRef colFolderPath As Collection) As Long ' フォルダパスが "" の場合はフォルダ選択ダイアログボックスを表示 If FolderPath = "" Then With Application.FileDialog(msoFileDialogFolderPicker) .Title = "フォルダを選択してください" If .Show = True Then ' フォルダ選択 FolderPath = .SelectedItems(1) Else ' 「キャンセル」をクリックした場合は終了 getSubordinateFolders = -1 Exit Function End If End With End If ' ファイルシステムオブジェクトの生成 Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") ' フォルダの存在確認 存在しない場合は抜ける If Not fso.FolderExists(FolderPath) Then Exit Function ' コレクションにフォルダパスを追加 colFolderPath.Add FolderPath, CStr(colFolderPath.Count + 1) ' フォルダパスにフォルダ区切文字を追加 FolderPath = FolderPath & Application.PathSeparator On Error Resume Next Dim F As Object If 0 < fso.GetFolder(FolderPath).SubFolders.Count Then ' サブフォルダが存在する場合 配下のサブフォルダに移る For Each F In fso.GetFolder(FolderPath).SubFolders ' アクセス制限フォルダの場合は抜ける If F Is Nothing Then Exit Function '《再帰》 If getSubordinateFolders(FolderPath & F.Name, colFolderPath) = -1 Then getSubordinateFolders = -1 Exit For End If Next End If On Error GoTo 0 End Function
'-------------------------------------------------------------------------------- ' 対象セル範囲から任意の文字列を検索 '-------------------------------------------------------------------------------- '［引数］ ' rngTarget ：対象セル範囲 ' What ：検索する文字列 ' LookIn ：情報種類 値：xlValues[既定] 数式：xlFormulas コメント文：xlComments ' LookAt ：一致の種類 部分一致：xlPart[既定] 全体一致：xlWhole ' SearchOrder ：検索方法 1行ごと検索：xlByRows[既定] 1列ごと検索：xlByColumns ' SearchDirection：検索順 一致する次の値：xlNext[既定] 一致する前の値：xlPrevious ' MatchCase ：大文字・小文字の区別 区別する：True 区別しない：False[既定] ' MatchByte ：全角・半角の区別 区別する：True 区別しない：False[既定] '［戻り値］ ' 検索に一致したセルの集合 検索値がない場合はNothing '［作成日］2023.12.19 ［更新日］2025.11.22 ' https://excel.syogyoumujou.com/vba/find_allbooks.html '-------------------------------------------------------------------------------- Function findTargetCell(ByRef rngTarget As Range, _ ByVal What As String, _ Optional ByVal LookIn As XlFindLookIn = xlValues, _ Optional ByVal LookAt As XlLookAt = xlPart, _ Optional ByVal SearchOrder As XlSearchOrder = xlByRows, _ Optional ByVal SearchDirection As XlSearchDirection = xlNext, _ Optional ByVal MatchCase As Boolean = False, _ Optional ByVal MatchByte As Boolean = False) As Range ' 検索セル範囲を最適化 Set rngTarget = Intersect(rngTarget, rngTarget.Worksheet.UsedRange) If rngTarget Is Nothing Then Exit Function ' 検索実行 Dim rngFind As Range Set rngFind = rngTarget.Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte) ' 検索に一致のセルがない場合 If rngFind Is Nothing Then ' ※ 結合セルで検索に一致しないケースがあるため その対策処理 If SearchOrder = xlByRows Then SearchOrder = xlByColumns Else SearchOrder = xlByRows Set rngFind = rngTarget.Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte) If rngFind Is Nothing Then Exit Function End If Dim strAddress As String Dim rngUnion As Range strAddress = rngFind.Address '最初に検索一致したセルのアドレスを取得 Set rngUnion = rngFind Do Set rngUnion = Union(rngUnion, rngFind) 'セルを集合 Set rngFind = rngTarget.FindNext(rngFind) '次の一致セルを検索 If rngFind Is Nothing Then Exit Do Loop Until strAddress = rngFind.Address 'セルアドレスが最初のセルと同じ場合はループを抜ける Set findTargetCell = rngUnion End Function
