VBA to Search Folders and Subfolders for A Specific Worksheet in All Macro Enabled Workbooks Copy & Paste as Worksheet in New Workbook

[Jimean]

Hello,

I am fairly new to writing VBA codes. I was able to write a VBA code to search through our shared directory file path (main folder) to look through all macro-enabled workbooks (.xlsm) and search for a specific worksheet in each workbook, "DRT621".

The macro then compiles all of the worksheets, "DRT621" from all of the mulitple workbooks into one workbook and then renames the worksheets according to the entities' name.

The macro works great. However, I need to make the macro search through subfolders (subdirectories) also. And, I don't know how many levels of subfolder/subdirectories are under each main folder. Below is the code.

I've been referred to use the RDB Merge Add-in, which works great but unfortunately, I need each worksheet pulled to remain a separate worksheet (instead of merged all onto one worksheet) for audit support purpose.

Any help modifying this code so that it could look at many levels of subfolders would be very greatly appreciated!

Sub CopySheets1()
    Dim CurFile As String, DirLoc As String
    Dim DestWB As Workbook
    Dim ws As Object
    
    
    DirLoc = ThisWorkbook.Path & "\Test Shared Drive\"
    CurFile = Dir(DirLoc & "*.xlsm")
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Set DestWB = ActiveWorkbook
    
    Do While CurFile <> vbNullString
    Dim OrigWB As Workbook
    Dim wsName As String
    Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)

       
    For Each ws In OrigWB.Sheets
        If ws.Name = "DRT621" Then 'Update with each respective timing difference code
        ws.Copy After:=DestWB.Sheets(1)
    End If
    Next
       
    For Each ws In DestWB.Sheets
    If Left(ws.Name, 6) <> "DRT621" Then 'Update with each respective timing difference code
    Cells.Copy
    End If
    Next
    
    ActiveSheet.Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues
       
    OrigWB.Close SaveChanges:=False
    CurFile = Dir
Loop

Application.DisplayAlerts = False
Application.ScreenUpdating = True
Application.EnableEvents = True

Set DestWB = Nothing
       
MsgBox "Step 1 Completed", vbInformation
    
End Sub

Sub CopyData()
Dim Dest As Range
Dim ws As Worksheet
Set Dest = Worksheets("List of BUs").Cells(2, 1)
For Each ws In ActiveWorkbook.Worksheets
If Left(ws.Name, 6) <> "DRT621" Then GoTo NextSht
Dest.Value = ws.Range("C6").Value
Set Dest = Dest.Offset(1)
NextSht:
Next ws

MsgBox "Step 2 Completed", vbInformation

End Sub

Sub RenSht()
Dim i As Long
With ActiveWorkbook
For i = 2 To Worksheets.Count - 1
Worksheets(i).Name = Worksheets(Worksheets.Count).Range("A" & i).Value
Next i
End With

MsgBox "Step 3 Completed", vbInformation


End Sub