簡単！！エクセルVBAメモ
３.VBA応用（使用ケース集）
エクセル内検索(複数のエクセル）
エクセルを開いて、キーワードがあるかチェックしたいということも多々あるかと思います。
※最近ではIPが変更した場合や、DBの情報など変わったりするときに、
修正すべきドキュメントを探すときなどに使ってます。
（ちなみに、下のエクセル（セルの位置など）で、以下のプログラムをコピーすればそのまま使えるはずです
【サンプル処理イメージ】
①マクロを実行 ※検索条件などは事前に入れておく
②指定された検索フォルダにある（下位の階層を全て）、エクセルファイルを開いて、シートごとに検索ワードが 含まれるかチェックする。
③検索ワードが含まれる場合は、結果（B～D列)を貼り付けます。
【以下マクロを実行する上でのエクセルの書式など】
VBAサンプル
============================================
=== 開始！！===================================
============================================
Sub 複数エクセル検索()
'*************************************************************
'*** 【概要】
'*** 検索ワードが、指定した検索フォルダの配下にあるエクセルに含まれる場合は抽出する。
'*** ※該当ワードがあるエクセル（シート単位）を抽出する。
'***（処理を変えれば、入っているセルなども取得可能)
'***
'*** 【前提条件 】
'*** ①パスが指定できるがファイル名（パス含め）が259バイト以上の場合エラーとなる
'*** ②フォルダが10万件以上ある場合はエラー(配列を10万としている）
'*************************************************************
'*************************************************************
'*** １．定義
'*************************************************************
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 'オブジェクト用
'*************************************************************
'*** ２．初期処理
'*************************************************************
'非表示（基本的に長い処理と思われるため）
'Application.Visible = True
Application.Visible = False
'①前回データクリア**********************
Range("b20:z100000").Select
Selection.ClearContents
'②値設定*********************************
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
'*************************************************************
'*** ３．メイン処理（配下のフォルダを全て洗い出す）
'*************************************************************
'
'①データがなくなるまで繰り返す
Do Until DirName = ""
'ディレクトリにあるファイルを1件取得
FileName = Dir(DirName, vbDirectory)
Do While FileName <> ""
'②ファイル名を設定(検索したファイル名の（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 (ファイルパスに→文言含む②)
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 (ファイルパスに指定文言を含まない②)
If Cells(11, "c") <> "" Then
If InStr(DirName, Cells(11, "C")) > 0 Then
'パスに、「指定文言を含まない」為、次のデータへ
GoTo 999
End If
End If
'③ファイルオープン
'(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
'④シート内の検索（該当エクセルのシートがすべてなくなるまで処理)
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 'オプション１ 「１」は完全一致の場合
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 '※次のデータへ行く
'⑤該当エクセル全て確認した為、検索したエクセルを閉じる
Workbooks(FileName).Close SaveChanges:=False
888
'⑥階層チェック（ディレクトリの場合は、階層を抽出する。
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
'⑦同じディレクトリ内にある次のファイル読み込み処理
FileName = Dir()
If FileName = "検索（複数のエクセル）.xlsm" Then
'※同じエクセル名がいたらエラーになるので飛ばす
GoTo 999
End If
Loop
'⑧次のディレクトリのデータを取り出す。
out_cnt = out_cnt + 1
DirName = folder_wk(out_cnt)
Loop
'再表示（基本的に長い処理と思われるため）
Application.Visible = True
Cells(1, 1).Select
MsgBox ("処理終了")
End Sub
=============================================
=== 終了！！====================================
=============================================
トップページへ戻る