Dir関数を用いるため、ネットワーク上の長いファイルパスには未対応です。
Sub Test()
' 検索速度向上のポイント
' 何度も登場するブックやセルは変数に格納し、メモリを参照する。
' 画面チラつきを防止する。
' 画面チラつきを防止する。
Application.ScreenUpdating = False
' フォルダパスとファイル名を宣言する。
Dim strFilePath As String
Dim strFileNmae As String
' テキストボックスかセル入力でフォルダを指定させる。
strFilePath = "C:\Users\test\Desktop\テストディレクトリ"
' 末尾が\ではない場合、\を追加する。(未実装)
strFilePath = strFilePath & "\"
' 指定フォルダ内のファイル名を取得する。
strFileName = Dir(strFilePath, vbNormal)
' 結果シートを変数に設定する。
Dim resultBookSheet As Worksheet
Set resultBookSheet = Worksheets("sheet1")
' 結果シートの行数を宣言する。
Dim longGyo As Long
longGyo = 1
' 指定フォルダ内のファイルがなくなるまで繰り返す。
Do While strFileName <> ""
Dim result As Range
Dim firstAddress As String
' ファイルを開く。
With Workbooks.Open(Filename:=strFilePath & strFileName)
' ファイル内のシート数を取得する。
Dim sheetCnt As Long
sheetCnt = .Worksheets.Count
' 1シート目からnシート目まで繰り返す。
Dim i As Long
For i = 1 To sheetCnt
' What:=検索するデータを指定
' After:=検索を開始するセルを指定
' LookIn:=値を検索
' LookAt:=一部が一致するセルを検索
' SearchOrder:=列単位で検索(行単位のxlByColumnsを指定しているとセル結合が検索されない)
' SearchDirection:=順方向に検索
' MatchCase:=大文字と小文字を区別しない
' MatchByte:=半角と全角を区別しない
' SearchFormat:=セル書式は検索条件に指定しない
Set result = .Worksheets(i).Cells.Find(What:="APS" _
, After:=ActiveCell _
, LookIn:=xlValues _
, LookAt:=xlPart _
, SearchOrder:=xlByRows _
, SearchDirection:=xlNext _
, MatchCase:=False _
, MatchByte:=False _
, SearchFormat:=False)
If Not result Is Nothing Then
firstAddress = result.Address
Do
resultBookSheet.Cells(longGyo, 1).Value = strFilePath & strFileName
resultBookSheet.Cells(longGyo, 2).Value = .Worksheets(i).Name
' resultBookSheet.Cells(longGyo, 3).Value = "セル(" & result.Row & ", " & result.Column & ")"
resultBookSheet.Cells(longGyo, 3).Value = "セル(" & result.Address & ")"
resultBookSheet.Cells(longGyo, 4).Value = .Worksheets(i).Cells(result.Row, result.Column).Value
longGyo = longGyo + 1
Set result = .Worksheets(i).Cells.FindNext(result)
If result Is Nothing Then
Exit Do
End If
If result.Address = firstAddress Then
Exit Do
End If
Loop
End If
Next i
' 保存せずファイルを閉じる。
.Close SaveChanges:=False
End With
' 次のファイルを取得する。
strFileName = Dir()
Loop
' 画面チラつき防止を解除する。
Application.ScreenUpdating = True
End Sub