VBA 特定の文字を含む、複数ファイルから抽出

質問

はじめまして。
必要なデータが複数のファイルにまたがってバラバラに管理されており、必要なデータを取り出すために毎日苦労しています🥲ファイル毎に別担当が更新されているため統合される予定がなく途方にくれています。どなたかコード教えて下さい。切実。

【前提】
特定のフォルダ(階層はバラバラ)
Excelファイルが30個前後
ファイルによっては複数のシートがある
OSはWindows10
Office365　Excelです。

【検索方法】
メッセージボックスに検索したい文字列(例えば”AA-123“)と入力
できればワイルドカード文字も使いたいです。

【結果の表示】
第1希望　リンクとして表示
第2希望　ファイル名と行ごとコピー
第3希望　ファイル名とセル番地を表示

【複数のファイルがHITした場合の表示】
1件目をA1セルとA2セル
2件目を1行あけたA3セルとA4セル
3件目以降同様に、、、といった具合に全件を表示させたいです。
想定では多くて10件以下の見込です。

以上　難しいかもしれないのですが、どなたかお助けください。

回答No.7

HohoPapa

>>【前提】
>>特定のフォルダ(階層はバラバラ)
ここで言う、特定のフォルダーを

>　Application.DisplayAlerts = False
>　Call FindCheck("C:\work")
>　Application.DisplayAlerts = True
この記述部分の
"C:\work"　に指定して使うマクロです。

回答No.6

HohoPapa

>実行時エラー'76'
>パスが見つかりません。

当方では再現できませんが、
ＯＳは耐える一方で、
VBAでは耐えられないフォルダー名、あるいはフォルダー構成がある可能性を疑います。

後記コードにすることで
エミディエイト画面に処理するごとにフォルダー名を表示されますので
どのフォルダーが怪しいか、炙り出せるのではないかと思います。

Option Explicit

Dim Putrow As Long　'出力先行番号
Dim KeyWord As String　'検索文字列

Sub sample()
　KeyWord = InputBox("名前を入力してください")
　Putrow = 1
　Sheets.Add before:=ThisWorkbook.Sheets(1)
　With ThisWorkbook.Sheets(1)
　　.Cells(1, 1).Value = "ファイルへのリンク"
　　.Cells(1, 2).Value = "シート名"
　　.Cells(1, 3).Value = "セルのアドレス"
　　.Cells(1, 4).Value = "セルの値"
　　.Cells(1, 5).Value = KeyWord
　End With
　Application.DisplayAlerts = False
　Call FindCheck("C:\work")
　Application.DisplayAlerts = True
End Sub

Sub FindCheck(Path As String)

　Dim buf As String, f As Object
　Dim tgBook As Workbook

　Debug.Print Path　　'<<<追加行=========

　buf = Dir(Path & "\*.xlsx")
　Do While buf <> ""
　　Set tgBook = _
　　　　Workbooks.Open(Filename:=Path & "\" & buf, ReadOnly:=True)
　　Call sfFind(tgBook, KeyWord)
　　tgBook.Close
　　buf = Dir()
　Loop

　With CreateObject("Scripting.FileSystemObject")
　　For Each f In .GetFolder(Path).SubFolders
　　　Call FindCheck(f.Path)
　　Next f
　End With

End Sub

Sub sfFind(tgBook As Workbook, FindWord As String)

　Dim myRng As Range
　Dim ShCounter As Long
　Dim firstCell As Range
　Dim str As String

　For ShCounter = 1 To tgBook.Worksheets.Count
　　Set myRng = tgBook.Worksheets(ShCounter). _
　　　　Cells.Find(what:=FindWord, LookAt:=xlWhole)
　　If Not myRng Is Nothing Then
　　　Set firstCell = myRng
　　　Do
　　　　With ThisWorkbook.Sheets(1)
　　　　　Putrow = Putrow + 1
　　　　　.Hyperlinks.Add Anchor:=.Cells(Putrow, 1), Address:= _
　　　　　　　tgBook.Path & "\" & tgBook.Name, _
　　　　　　　TextToDisplay:=tgBook.Path & "\" & tgBook.Name
　　　　　.Cells(Putrow, 2).Value = Worksheets(ShCounter).Name
　　　　　.Cells(Putrow, 3).Value = myRng.Address
　　　　　.Cells(Putrow, 4).Value = myRng.Value
　　　　End With

　　　　Set myRng = tgBook.Worksheets(ShCounter). _
　　　　Cells.FindNext(myRng)
　　　　If firstCell.Address = myRng.Address Then Exit Do
　　　Loop
　　End If
　Next ShCounter

End Sub

補足

イミディエイトウィンドウで観察すると、
C:￥work
が表示されました。

尚、ファイルの保存先を次の状態にして試しています。
①Cドライブの直下に1つのファイル保存。
②Cドライブの直下にフォルダを1つ作成し、そこへファイルを保存。

この環境にして実行しても同様のエラーでした。
やはり難しいですね＞＜

回答No.5

HohoPapa

>For Each f In .GetFoder(path).SubFoldersで止まってしまいます。
具体的な症状（エラーコードなど）を教えてください。

補足

実行時エラー'76'
パスが見つかりません。

です。

回答No.4

HohoPapa

>【複数のファイルがHITした場合の表示】
これ以降の記述を見落としていました。

また、質問文を読み直してみたところ、
複数階層に複数のフォルダー、
それぞれに複数のブックがあり、
ブックには複数シートがあり、
シート内の複数のセルがヒットする可能性があるということでしょうから
コードを改めて書き直してみました。

Option Explicit

Dim Putrow As Long　'出力先行番号
Dim KeyWord As String　'検索文字列

Sub sample()
　KeyWord = InputBox("名前を入力してください")
　Putrow = 1
　Sheets.Add before:=ThisWorkbook.Sheets(1)
　With ThisWorkbook.Sheets(1)
　　.Cells(1, 1).Value = "ファイルへのリンク"
　　.Cells(1, 2).Value = "シート名"
　　.Cells(1, 3).Value = "セルのアドレス"
　　.Cells(1, 4).Value = "セルの値"
　　.Cells(1, 5).Value = KeyWord
　End With
　Application.DisplayAlerts = False
　Call FindCheck("C:\work")
　Application.DisplayAlerts = True
End Sub

Sub FindCheck(Path As String)

　Dim buf As String, f As Object
　Dim tgBook As Workbook

　buf = Dir(Path & "\*.xlsx")
　Do While buf <> ""
　　Set tgBook = _
　　　　Workbooks.Open(Filename:=Path & "\" & buf, ReadOnly:=True)
　　Call sfFind(tgBook, KeyWord)
　　tgBook.Close
　　buf = Dir()
　Loop

　With CreateObject("Scripting.FileSystemObject")
　　For Each f In .GetFolder(Path).SubFolders
　　　Call FindCheck(f.Path)
　　Next f
　End With

End Sub

Sub sfFind(tgBook As Workbook, FindWord As String)

　Dim myRng As Range
　Dim ShCounter As Long
　Dim firstCell As Range
　Dim str As String

　For ShCounter = 1 To tgBook.Worksheets.Count
　　Set myRng = tgBook.Worksheets(ShCounter). _
　　　　Cells.Find(what:=FindWord, LookAt:=xlWhole)
　　If Not myRng Is Nothing Then
　　　Set firstCell = myRng
　　　Do
　　　　With ThisWorkbook.Sheets(1)
　　　　　Putrow = Putrow + 1
　　　　　.Hyperlinks.Add Anchor:=.Cells(Putrow, 1), Address:= _
　　　　　　　tgBook.Path & "\" & tgBook.Name, _
　　　　　　　TextToDisplay:=tgBook.Path & "\" & tgBook.Name
　　　　　.Cells(Putrow, 2).Value = Worksheets(ShCounter).Name
　　　　　.Cells(Putrow, 3).Value = myRng.Address
　　　　　.Cells(Putrow, 4).Value = myRng.Value
　　　　End With

　　　　Set myRng = tgBook.Worksheets(ShCounter). _
　　　　Cells.FindNext(myRng)
　　　　If firstCell.Address = myRng.Address Then Exit Do
　　　Loop
　　End If
　Next ShCounter

End Sub

補足

For Each f In .GetFoder(path).SubFoldersで止まってしまいます。

自分でも原因を調べてみようと思いますが、この構文は初心者の私には難しく、
もしお時間ありましたらご教示賜われましたら幸いです。

回答No.3

HohoPapa

時間ができたので、試しに書いてみました。
よかったら試してみてください。

なお、
>特定のフォルダ(階層はバラバラ)
これは特定のフォルダー以下にフォルダーと調査対象のエクセルブックがある。
ということでいいですね？

また、
>第1希望　リンクとして表示
これは、マクロブックの先頭にシートを挿入し
その2行目から書き出しています。

更に
>Excelファイルが30個前後
これは、拡張子が".xlsx"を対象にしています。

Option Explicit

Dim Putrow As Long　'出力先行番号
Dim KeyWord As String　'検索文字列

Sub sample()

　KeyWord = InputBox("名前を入力してください")
　Putrow = 1
　Sheets.Add before:=ThisWorkbook.Sheets(1)
　Application.DisplayAlerts = False
　Call FindCheck("C:\work")
　Application.DisplayAlerts = True

End Sub

Sub FindCheck(Path As String)

　Dim buf As String, f As Object
　Dim tgBook As Workbook

　buf = Dir(Path & "\*.xlsx")
　Do While buf <> ""
　　Set tgBook = _
　　　　Workbooks.Open(Filename:=Path & "\" & buf, ReadOnly:=True)
　　'Debug.Print Path & "\" & buf
　　If sfFind(tgBook, KeyWord) = True Then
　　　With ThisWorkbook.Sheets(1)
　　　　Putrow = Putrow + 1
　　　　.Hyperlinks.Add Anchor:=.Cells(Putrow, 1), Address:= _
　　　　　 Path & "\" & buf, TextToDisplay:=Path & "\" & buf
　　　End With
　　End If
　　tgBook.Close
　　buf = Dir()
　Loop
　With CreateObject("Scripting.FileSystemObject")
　　For Each f In .GetFolder(Path).SubFolders
　　　Call FindCheck(f.Path)
　　Next f
　End With

End Sub

Function sfFind(tgBook As Workbook, FindWord As String) As Boolean

　Dim myRng As Range
　Dim ShCounter As Long

　sfFind = False
　For ShCounter = 1 To tgBook.Worksheets.Count
　　Set myRng = tgBook.Worksheets(ShCounter). _
　　　　Cells.Find(what:=FindWord, LookAt:=xlWhole)
　　'Debug.Print tgBook.Name & tgBook.Worksheets(ShCounter).Name
　　If Not myRng Is Nothing Then
　　　sfFind = True
　　　Exit For
　　End If
　Next ShCounter

End Function

お礼

ありがとうございます🥲
家に帰ったら早速やってみます！

回答No.2

imogasi

自分が困っているからと言って、VBAは少しでも、やっているか？
ここは、他の生活相談的な質問と違って、「課題を文章にして、コード作成を注文する」ところではない。
プログラム作成は、本来有価物のはず。日本もソフトで世界と勝負する時代で、学校教育も舵を切ったようだ。社内のシステム担当や、業者に頼むのが筋のはず（業者は５万円以下では引き受けてくれるかな？）。
ーー
既回答の方がご指摘のように、ウインドウズの付属のエクスプローラーの機能の中に、ファイルの中身（文字列？）まで調べる機能がある。小生、十分活用できてないが、これでも使えないか？
ーー
まず、順を追って、どういうプロセスが必要か整理しろ。
（１）対象とする、ファイル形式はエクセルらしい
（２）フォルダは５個以内ぐらい、をいつも、チェックすれば良いらしい。
　　　　その名前をシートに上げろ。上げられるか？難しい点あるか。
　　　　それぞれで、ファイル名の文字列が、毎回（月）部分的に変化するなら、それを説明しろ。
　　　　ファイルは全てで、３０個ぐらい？
（３）その文字列について、どこを探すのか
　　　フォルダ名ではないだろうが。
　　　ファイル名、シート名、シートのセル範囲、その他
（４）文字列によるシートデータ（値）のあり場所を探すには、Range( ).Findがメインのおすすめ機能の　　　　ようだ。
　　　考え方が独特なところがあり、昔、学習時に難しかった。
＝＝＝
全般にエクセルやFSOで、およそ、何ができるか勉強したうえで、
処理ステップを時系列的に、箇条書きしろ。
そこで１つずつ、ＷＥＢで照会して、似たコードを見つけろ。
ーー
後は処理を書き連ねればよい。
しかし前段階で見つけた、決まった文字列などを後段に引き渡すのも簡単ではないが。
＝＝＝＝
質問文だけでは全体像が見えない。その後のことなど。普通はこれが前段に影響するもんだ。
だから、とりあえず、出来る各１ステップだけVBA化し、間のつなぎは、人間の判断を温存する方針がよいと思う。
本質問は１遍に欲張りすぎだと思う。

回答No.1

kkkkkm

Windowsの機能で検索すればいいのではないでしょうか。
Windows 10でファイルを検索する方法
https://office-hack.com/windows/windows10-file-search/