VBA Import Data from Multiple Folders

[MBD]

Hi All,

I'm trying to modify below VBA code to automatically import multiple files from all folders which are all named consistently.
What I'm looking to change:
1) All folder names currently have to be defined within the code, while I'm trying to automatically pick up hundreds of different folders (all starts with Team - i.e. TeamDelta, TeamAlpha, etc.) - is there any way to automate this without having to include the folder names one by one?
2) Currently the code will merge all data and paste it into one new sheet in a new workbook. I'm trying to paste it into an already existing sheet called 'TeamSummary' in my current workbook.

Any help would be appreciated.
Thanks in Advance!

Sub MasterWorkbook()
Application.ScreenUpdating = False
Dim arr As Variant, i As Long
Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim folderName As String, fileName As String, chr As String
Dim lastRow1 As Long, lastRow2 As Long, kount As Long

arr = Array("C:\Users\Marco\Desktop\BookingReport\Team1\", _
    "C:\Users\Marco\Desktop\BookingReport\Team2\", _
    "C:\Users\Marco\Desktop\BookingReport\Team3")

Set wb1 = ThisWorkbook
For i = 0 To 2
    folderName = arr(i)
    fileName = Dir(folderName & "*.xlsx")
    Do While fileName <> ""
        chr = Left(fileName, 1)
        If fileName <> wb1.Name And chr = "P" Or chr = "C" Then
            Set wb2 = Workbooks.Open(folderName & fileName)
                For Each ws2 In wb2.Worksheets
                    For Each ws1 In wb1.Worksheets
                        If ws2.Name = ws1.Name Then
                            If ws2.Range("A3") <> "" Then
                                lastRow2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
                                lastRow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
                                kount = lastRow2 - 2
                                ws2.Range("A3:E" & lastRow2).Copy
                                ws1.Range("A" & lastRow1 + 1).PasteSpecial Paste:=xlPasteValues
                                ws1.Range("F" & lastRow1 + 1 & ":F" & lastRow1 + 1 + kount).Value = Left(fileName, 6)
                            End If
                            Exit For
                        End If
                    Next ws1
                Next ws2
            wb2.Close savechanges:=False
        End If
    fileName = Dir
    Loop
Next i

Application.ScreenUpdating = True

End Sub

 

[John_w]

1) All folder names currently have to be defined within the code, while I'm trying to automatically pick up hundreds of different folders (all starts with Team - i.e. TeamDelta, TeamAlpha, etc.) - is there any way to automate this without having to include the folder names one by one?

Replace the Dir function loop with a recursive FileSystemObject procedure which starts at a base folder path. There are many examples on the forum.

2) Currently the code will merge all data and paste it into one new sheet in a new workbook. I'm trying to paste it into an already existing sheet called 'TeamSummary' in my current workbook.

ThisWorkbook.Worksheets("TeamSummary")