Вам понадобится рекурсивная функция для поиска всех подпапок из заданной начальной папки. Нечто подобное должно работать у вас:
Sub tgr()
Dim wbDest As Workbook
Dim rDest As Range
Dim rClear As Range
Dim aResults() As Variant
Dim sFolderPath As String
Dim aSheetNames As Variant
Dim ixResult As Long
Dim msoMacroSetting As MsoAutomationSecurity
Set wbDest = ThisWorkbook
Set rDest = wbDest.Worksheets("Sheet1").Range("A2") 'Change this to the correct sheetname and cell where results should be output to
sFolderPath = "C:\Test" 'Change this to the correct folder path where you want to start your search
aSheetNames = Array("RUNREADY", "Run Ready") 'Change this to the list correct sheet names you are searching for, note that it ignores case
ReDim aResults(1 To 65000, 1 To 1) 'Assumes a maximum number of identified results of 65000
ixResult = 0
'Prevent workbook open code, prevent screen flickering, prevent calculations
'This will let the code run smoother and faster without interruptions
With Application
msoMacroSetting = .AutomationSecurity
.AutomationSecurity = msoAutomationSecurityForceDisable
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Call the recursive function ExcelFileSheetSearch
ExcelFileSheetSearch sFolderPath, aSheetNames, aResults, ixResult
'Re-enable what was disabled
With Application
.AutomationSecurity = msoMacroSetting
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
'Check if any workbooks were positively identified
If ixResult > 0 Then
'Clear previous results, preserving headers (if any)
Set rClear = rDest.CurrentRegion
rClear.Offset(rDest.Row - rClear.Row).ClearContents
'Output results
rDest.Resize(ixResult, UBound(aResults, 2)).Value = aResults
Else
MsgBox "No workbooks found in [" & sFolderPath & "] or any of its subfolders containing worksheets named: " & Chr(10) & Join(aSheetNames, Chr(10))
End If
End Sub
Public Function ExcelFileSheetSearch(ByVal arg_sFolder As String, ByVal arg_vFindSheet As Variant, ByRef arg_aList As Variant, ByRef arg_ixList As Long) As Variant
'This is a recursive function that checks a given folder and all of its subfolders for Excel workbooks
'If any of the workbooks contain a worksheet with a specific name, it will add the folder path and file name to the results list
Dim wb As Workbook
Dim aSheets As Variant
Dim vSheet As Variant
Dim sFolder As String
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim oSubFolder As Object
Dim bSheetFound As Boolean
'Ensure correct folder path structure
If Right(arg_sFolder, Len(Application.PathSeparator)) <> Application.PathSeparator Then sFolder = arg_sFolder & Application.PathSeparator Else sFolder = arg_sFolder
If Len(Dir(sFolder, vbDirectory)) = 0 Then Exit Function 'Invalid folder path provided
If IsArray(arg_vFindSheet) Then
aSheets = arg_vFindSheet
Else
ReDim aSheets(1 To 1)
aSheets(1) = arg_vFindSheet
End If
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.getfolder(sFolder)
'Loop through the given folder path looking for Excel files
'Open found Excel files and check if the given sheet name exists
For Each oFile In oFolder.Files
bSheetFound = False
If (LCase(Right(oFile.Name, InStrRev(oFile.Name, "."))) Like LCase("*.xls*")) Then
Set wb = Workbooks.Open(sFolder & oFile.Name)
'Loop through each sheet name that is being searched for
For Each vSheet In aSheets
If SheetExists(CStr(vSheet), wb) Then
bSheetFound = True
Exit For
End If
Next vSheet
If bSheetFound Then
arg_ixList = arg_ixList + 1
arg_aList(arg_ixList, 1) = sFolder & oFile.Name
End If
wb.Close False
End If
Next oFile
'Function calls itself for each subfolder to run the check again
For Each oSubFolder In oFolder.SubFolders
ExcelFileSheetSearch sFolder & oSubFolder.Name, arg_vFindSheet, arg_aList, arg_ixList
Next oSubFolder
End Function
Public Function SheetExists(ByRef arg_sSheetName As String, Optional ByRef arg_wb As Workbook) As Boolean
'This function checks if a specific sheet name exists within a workbook
Dim wb As Workbook
Dim ws As Worksheet
If arg_wb Is Nothing Then Set wb = ActiveWorkbook Else Set wb = arg_wb
On Error Resume Next
Set ws = wb.Worksheets(arg_sSheetName)
On Error GoTo 0
SheetExists = (Not (ws Is Nothing))
End Function