VBAサンプル
============================================
=== 開始!!===================================
============================================
Sub 複数エクセル検索()
'*************************************************************
'*** 【概要】
'*** 検索ワードが、指定した検索フォルダの配下にあるエクセルに含まれる場合は抽出する。
'*** ※該当ワードがあるエクセル(シート単位)を抽出する。
'***(処理を変えれば、入っているセルなども取得可能)
'***
'*** 【前提条件 】
'*** @パスが指定できるがファイル名(パス含め)が259バイト以上の場合エラーとなる
'*** Aフォルダが10万件以上ある場合はエラー(配列を10万としている)
'*************************************************************
'*************************************************************
'*** 1.定義
'*************************************************************
Dim DirName As String 'ディレクトリ名用
Dim FileName As String 'ファイル名用
Dim gyo1 As Variant '行
Dim gyo2 As Variant '行
Dim gyo3 As Variant '行
Dim kensaku As String '検索文字列
Dim folder_wk(100000) As String 'WK配列エリア
Dim in_cnt As Variant 'ディレクトリ用(配列入力用)
Dim out_cnt As Variant 'ディレクトリ用(配列出力用)
Dim book1 As Workbook '開いたブックのWKエリア
Dim kensaku_kekka As Range '検索結果
Dim Obj As Object 'オブジェクト用
'*************************************************************
'*** 2.初期処理
'*************************************************************
'非表示(基本的に長い処理と思われるため)
'Application.Visible = True
Application.Visible = False
'@前回データクリア**********************
Range("b20:z100000").Select
Selection.ClearContents
'A値設定*********************************
gyo1 = 20 '出力エリア(結果)
gyo2 = 20 '出力エリア(検索ファイル※全て)
gyo3 = 20 '出力エリア(検索ファイル※エクセルのみ)
in_cnt = 1
out_cnt = 0
'1件目に指定のディレクトリを設定
folder_wk(0) = DirName
kensaku = Cells(2, 3) '検索ワード
'対象ディレクトリ設定(以下階層全て)
If Right(Cells(3, 3), 1) = "\" Then 'ディレクトリの最後に「\]なければつける
DirName = Cells(3, 3)
Else
DirName = Cells(3, 3) & "\"
End If
'*************************************************************
'*** 3.メイン処理(配下のフォルダを全て洗い出す)
'*************************************************************
'
'@データがなくなるまで繰り返す
Do Until DirName = ""
'ディレクトリにあるファイルを1件取得
FileName = Dir(DirName, vbDirectory)
Do While FileName <> ""
'Aファイル名を設定(検索したファイル名の(T,U列に保存)
Cells(gyo2, "T") = DirName
Cells(gyo2, "U") = FileName
gyo2 = gyo2 + 1
'(1)「?」除外
If InStr(FileName, "?") > 0 Then
GoTo 999 'ファイル名に「?」が含まれる為、次のデータへ
End If
'(2)パスが259バイト以上の場合は、検索しない(除外理由に設定)
If LenB(DirName & FileName) > 258 Then
Cells(gyo2 - 1, "V") = "259バイト以上の為除外"
GoTo 999 'パスが「259バイト以上」の為、次のデータへ
End If
'(3)検索ファイルチェック(エクセルファイル)
If Right(FileName, 4) = ".xls" Or Right(FileName, 4) = ".xlm" Or Right(FileName, 5) = ".xlsx" Or Right(FileName, 5) = ".xlsm" Then
Else
'ファイルが「エクセルでない」為、次の処理へ888へ遷移
GoTo 888
End If
'(4)オプション2 (ファイルパスに→文言含む@)
If Cells(8, "c") <> "" Then
If InStr(DirName, Cells(8, "c")) = 0 Then
'パスに、「指定文言を含まない」為、次のデータへ
GoTo 999
End If
End If
'(5)オプション3 (ファイルパスに→文言含むA)
If Cells(9, "c") <> "" Then
'パスに、「指定文言を含まない」為、次のデータへ
GoTo 999
End If
End If
'(6)オプション4 (ファイルパスに指定文言を含まない@)
If Cells(10, "c") <> "" Then
If InStr(DirName, Cells(10, "C")) > 0 Then
'パスに、「指定文言を含まない」為、次のデータへ
GoTo 999
End If
End If
'(7)オプション5 (ファイルパスに指定文言を含まないA)
If Cells(11, "c") <> "" Then
If InStr(DirName, Cells(11, "C")) > 0 Then
'パスに、「指定文言を含まない」為、次のデータへ
GoTo 999
End If
End If
'Bファイルオープン
'(1)オープンしたエクセルを記録する。
Cells(gyo3, "G") = DirName
Cells(gyo3, "H") = FileName
gyo3 = gyo3 + 1
'(2)ファイル名設定
fullpath = DirName & FileName
'(3)ファイルオープン
On Error Resume Next '※エラーがある場合は次のファイルを開く
Workbooks.Open fullpath, ReadOnly:=True, UpdateLinks:=0
If Err.Number <> 0 Then
GoTo 999 'ファイルオープンでエラー有り
End If
'(4)ブックの変更
Set book1 = Application.Workbooks(FileName)
book1.Activate
'Cシート内の検索(該当エクセルのシートがすべてなくなるまで処理)
For Each Obj In ActiveWorkbook.Sheets
bkup = sheets_name
sheets_name = Obj.Name
'(1)一つシートを選んで切り替える
'うまくいかない場合は画面表示させ確認
'Worksheets(Obj.Name).Visible = True
Sheets(Obj.Name).Select
'(2)該当シート内を検索
If wk_flg = 1 Then 'オプション1 「1」は完全一致の場合
Set kensaku_kekka = Cells.Find(What:=kensaku, LookIn:=xlValues, LookAt:=xlWhole)
Else
Set kensaku_kekka = Cells.Find(What:=kensaku, LookIn:=xlValues, LookAt:=xlPart)
End If
'(3)検索結果を確認(該当データあれば、操作しているエクセルに記載する)
If Not kensaku_kekka Is Nothing Then
Set book1 = Application.Workbooks("検索(複数のエクセル).xlsm")
book1.Activate
Sheets("メイン").Select
'各情報を設定
Cells(gyo1, "B") = "'" & FileName
Cells(gyo1, "C") = "'" & Obj.Name
Cells(gyo1, "D") = "'" & fullpath
gyo1 = gyo1 + 1
'検索しているエクセルに設定を戻す
Set book1 = Application.Workbooks(FileName)
book1.Activate
Sheets(Obj.Name).Select
End If
Next Obj '※次のデータへ行く
'D該当エクセル全て確認した為、検索したエクセルを閉じる
Workbooks(FileName).Close SaveChanges:=False
888
'E階層チェック(ディレクトリの場合は、階層を抽出する。
If GetAttr(DirName & FileName) And vbDirectory Then
If FileName = "." Or FileName = ".." Then
Else
'ディレクトリを格納
folder_wk(in_cnt) = DirName & FileName & "\"
in_cnt = in_cnt + 1
End If
End If
999
'F同じディレクトリ内にある次のファイル読み込み処理
FileName = Dir()
If FileName = "検索(複数のエクセル).xlsm" Then
'※同じエクセル名がいたらエラーになるので飛ばす
GoTo 999
End If
Loop
'G次のディレクトリのデータを取り出す。
out_cnt = out_cnt + 1
DirName = folder_wk(out_cnt)
Loop
'再表示(基本的に長い処理と思われるため)
Application.Visible = True
Cells(1, 1).Select
MsgBox ("処理終了")
End Sub
=============================================
=== 終了!!====================================
=============================================