VBA Import Data from Multiple Folders

MBD

New Member
Joined
Aug 25, 2021
Messages
11
Office Version
  1. 365
Platform
  1. Windows
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!

VBA Code:
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
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,127
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")
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,962
Messages
5,767,350
Members
425,405
Latest member
jaskimo

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top