How to loop through workbooks in a folder and import data to a master workbook VBA?

B

Bobstar

New Member
Joined
Oct 7, 2020
Messages
20
Office Version
  1. 2019
Platform
  1. Windows
Hi all

I am desperately looking for help to automate my work. I am looking for help with a code that can do the following:
  1. Open a folder
  2. Loop through multiple workbooks in that folder
  3. For each workbook in that folder, import data contained in the "Summary" sheet to thisWorkbook (workbook containing the code) in sheet named "Data"
PS: The columns in the Summary worksheet are fixed (A:G) but the rows are variable depending on the workbook.

Your help is very much appreciated.

Thanks
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Sort by date Sort by votes
Hi
Try this
VBA Code: 
Sub selected_Workbooks()
    Dim MyFolder As String
    Dim myPath As String
    Dim MyFile As String
    Dim fDialog As FileDialog
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    Dim wbk As Workbook
    Dim dist As Workbook
    Dim a As Variant
    On Error Resume Next
    Set dist = ActiveWorkbook
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Data").Select
    [A:G].ClearContents
    With fDialog
        .AllowMultiSelect = True
        .Title = "Please select the files"
        .Filters.Clear
        .Filters.Add "All supported files", "*.xlsm"
        .Filters.Add "Text Files", "*.xlsx"
        If .Show = True Then
            Dim fPath As Variant
            For Each fPath In .SelectedItems
                Set wbk = Workbooks.Open(Filename:=fPath)
                With wbk
                    .Sheets("Draft").Select
                    a = .Sheets("Summary").UsedRange.Columns("A:G").Value
                End With
                wbk.Close savechanges:=True
                Sheets("Data").Select
                lr = Sheets("Data").Cells(Sheets("Data").Rows.Count, "b").End(xlUp).Row
                If lr = 1 Then
                    Cells(lr, 1).Resize(UBound(a1, 1), UBound(a1, 2)) = a
                Else
                    Cells(lr + 1, 1).Resize(UBound(a1, 1), UBound(a1, 2)) = a
                  
                End If
            Next
        End If
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
Not tested
 
Upvote 0
mohadin said:
Hi
Try this
VBA Code: 
Sub selected_Workbooks()
    Dim MyFolder As String
    Dim myPath As String
    Dim MyFile As String
    Dim fDialog As FileDialog
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    Dim wbk As Workbook
    Dim dist As Workbook
    Dim a As Variant
    On Error Resume Next
    Set dist = ActiveWorkbook
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Data").Select
    [A:G].ClearContents
    With fDialog
        .AllowMultiSelect = True
        .Title = "Please select the files"
        .Filters.Clear
        .Filters.Add "All supported files", "*.xlsm"
        .Filters.Add "Text Files", "*.xlsx"
        If .Show = True Then
            Dim fPath As Variant
            For Each fPath In .SelectedItems
                Set wbk = Workbooks.Open(Filename:=fPath)
                With wbk
                    .Sheets("Draft").Select
                    a = .Sheets("Summary").UsedRange.Columns("A:G").Value
                End With
                wbk.Close savechanges:=True
                Sheets("Data").Select
                lr = Sheets("Data").Cells(Sheets("Data").Rows.Count, "b").End(xlUp).Row
                If lr = 1 Then
                    Cells(lr, 1).Resize(UBound(a1, 1), UBound(a1, 2)) = a
                Else
                    Cells(lr + 1, 1).Resize(UBound(a1, 1), UBound(a1, 2)) = a
                 
                End If
            Next
        End If
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
Not tested
Click to expand...

Thanks for this. It seems to be working. A couple of questions:
  • Instead of letting the user select the files, I would like the user to input the file path in a cell and macro to reference that cell.
  • You have used select several times in your script. Any way we could do without it to speed the macro?

Thanks
 
Upvote 0
Hi
Like This
file path in" K2 down sheets Data
VBA Code: 
Sub selected_Workbooks()
    Dim wbk As Workbook
    Dim a, MyFiles As Variant
    Dim lr, i As Double
    Dim fPath As Variant
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Data").[A:G].ClearContents
    fPath = Sheets("Data").Range("k2:k" & Cells(Rows.Count, "k").End(xlUp).Row).Value
    For i = 1 To UBound(fPath)
        Set wbk = Workbooks.Open(Filename:=fPath(i, 1))
        a = wbk.Sheets("Summary").UsedRange.Columns("A:G").Value
        wbk.Close savechanges:=True
        lr = Sheets("Data").Cells(Sheets("Data").Rows.Count, "b").End(xlUp).Row
        If lr = 1 Then
            Cells(lr, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
        Else
            Cells(lr + 1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
mohadin said:
Hi
Like This
file path in" K2 down sheets Data
VBA Code: 
Sub selected_Workbooks()
    Dim wbk As Workbook
    Dim a, MyFiles As Variant
    Dim lr, i As Double
    Dim fPath As Variant
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Data").[A:G].ClearContents
    fPath = Sheets("Data").Range("k2:k" & Cells(Rows.Count, "k").End(xlUp).Row).Value
    For i = 1 To UBound(fPath)
        Set wbk = Workbooks.Open(Filename:=fPath(i, 1))
        a = wbk.Sheets("Summary").UsedRange.Columns("A:G").Value
        wbk.Close savechanges:=True
        lr = Sheets("Data").Cells(Sheets("Data").Rows.Count, "b").End(xlUp).Row
        If lr = 1 Then
            Cells(lr, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
        Else
            Cells(lr + 1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
Click to expand...
Hi. Thanks for the updated code. However, it didn't work. I have written a code that seems to do the job. At the moment it is using the clipboard to do copy and paste. I tried assigning values but couldn't get it work. The copy option works but copies data across as formulas, I would like only values. Any ideas?

Private Sub CommandButton1_Click()

Dim sFile As String, myPath As String
Dim wbSource As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim scell As Range
Dim lrow As Long, ldestrow As Long
Dim rgSource As Range, rgDestination As Range

'optimise macro speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'set target worksheet
Set wsTarget = Sheets("Data")

'clear existing contents in target sheet
wsTarget.Cells.Clear

myPath = Range("D6") & Application.PathSeparator

'loop through the excel files in the folder
sFile = Dir(myPath & "*.xlsx")

Do While sFile <> ""

'open the source file and set source worksheet
Set wbSource = Workbooks.Open(myPath & sFile, ReadOnly:=True)
Set wsSource = wbSource.Worksheets("Summary")
Set scell = wsSource.Range("A1")

'find last row in source data
lrow = wsSource.Cells(wsSource.Rows.Count, scell.Column).End(xlUp).Row
Set rgSource = wsSource.Range(scell, wsSource.Cells(lrow, 7))

'find first blank row in target worksheetbasedon data in column A
'offset property moves down 1 row
ldestrow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(1).Row
Set rgDestination = wsTarget.Range("A" & ldestrow)

'copy and paste data
'wsSource.Range(scell, wsSource.Cells(lrow, 7)).Copy wsTarget.Range("A" & ldestrow)
'rgDestination.Value = rgSource.Value - not working
'Set rgDestination = rgDestination.Resize(rgSource.Rows.Count, rgSource.Columns.Count)
rgSource.Copy
rgDestination.PasteSpecial xlPasteValues

'close the source workbook
Application.DisplayAlerts = False
wbSource.Close savechanges:=False

'Get nextfile
sFile = Dir()
Loop

'reset settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub
 
Upvote 0
All right
Now I see
My code is working ok but missed what you meant
Any way give this version a try If you like
VBA Code: 
Sub Bobstar()
    Dim wbk As Workbook
    Dim a, MyFiles As Variant
    Dim lr, i As Double
    Dim myPath, sfile As Variant
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Data").[A:G].ClearContents
    myPath = Range("D6") & Application.PathSeparator
    sfile = Dir(myPath & "*.xlsx")
    Do While sfile <> ""
        Set wbk = Workbooks.Open(myPath & sfile, ReadOnly:=True)
        a = wbk.Sheets("Summary").UsedRange.Columns("A:G").Value
        wbk.Close savechanges:=True
        lr = Sheets("Data").Cells(Sheets("Data").Rows.Count, "b").End(xlUp).Row
        If lr = 1 Then
            Cells(lr, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
        Else
            Cells(lr + 1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
        End If
        sfile = Dir()
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub


For your code
check this line of code
Code: 
        rgSource.Copy rgDestination.PasteSpecial(xlPasteValues)
 
Upvote 0
Private Sub CommandButton1_Click()

Dim sFile As String, myPath As String
Dim wbSource As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim scell As Range
Dim lrow As Long, ldestrow As Long
Dim rgSource As Range, rgDestination As Range

'optimise macro speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'set target worksheet
Set wsTarget = Sheets("Data")

'clear existing contents in target sheet
wsTarget.Cells.Clear

myPath = Range("D6") & Application.PathSeparator

'loop through the excel files in the folder
sFile = Dir(myPath & "*.xlsx")

Do While sFile <> ""

'open the source file and set source worksheet
Set wbSource = Workbooks.Open(myPath & sFile, ReadOnly:=True)
Set wsSource = wbSource.Worksheets("Summary")
Set scell = wsSource.Range("A1")

'find last row in source data
lrow = wsSource.Cells(wsSource.Rows.Count, scell.Column).End(xlUp).Row
Set rgSource = wsSource.Range(scell, wsSource.Cells(lrow, 7))

'find first blank row in target worksheetbasedon data in column A
'offset property moves down 1 row
ldestrow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(1).Row
Set rgDestination = wsTarget.Range("A" & ldestrow)

'copy and paste data
'wsSource.Range(scell, wsSource.Cells(lrow, 7)).Copy wsTarget.Range("A" & ldestrow)
'rgDestination.Value = rgSource.Value - not working
'Set rgDestination = rgDestination.Resize(rgSource.Rows.Count, rgSource.Columns.Count)
rgSource.Copy
rgDestination.PasteSpecial xlPasteValues

'close the source workbook
Application.DisplayAlerts = False
wbSource.Close savechanges:=False

'Get nextfile
sFile = Dir()
Loop

'reset settings
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub
mohadin said:
All right
Now I see
My code is working ok but missed what you meant
Any way give this version a try If you like
VBA Code: 
Sub Bobstar()
    Dim wbk As Workbook
    Dim a, MyFiles As Variant
    Dim lr, i As Double
    Dim myPath, sfile As Variant
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Data").[A:G].ClearContents
    myPath = Range("D6") & Application.PathSeparator
    sfile = Dir(myPath & "*.xlsx")
    Do While sfile <> ""
        Set wbk = Workbooks.Open(myPath & sfile, ReadOnly:=True)
        a = wbk.Sheets("Summary").UsedRange.Columns("A:G").Value
        wbk.Close savechanges:=True
        lr = Sheets("Data").Cells(Sheets("Data").Rows.Count, "b").End(xlUp).Row
        If lr = 1 Then
            Cells(lr, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
        Else
            Cells(lr + 1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
        End If
        sfile = Dir()
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub


For your code
check this line of code
Code: 
        rgSource.Copy rgDestination.PasteSpecial(xlPasteValues)
Click to expand...
Thanks alot for your continued help. I like your array approach as it should run faster than assigning or copy paste. A couple of observations when I run your code:
  1. It is copying data in the wrong sheet. I have assigned the code to an active x button in a sheet named "Dashboard". Your code is copying data to this sheet ("Dashboard") rather than to sheet named "data".
  2. It seems to be looping through the files but only copying data from one file.
 
Upvote 0
Well
In This case ( active x button in a sheet named "Dashboard" )
VBA Code: 
Sub Bobstar2()
    Dim wbk As Workbook
    Dim a, MyFiles As Variant
    Dim lr, i As Double
    Dim myPath, sfile As Variant
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    myPath = Range("D6") & Application.PathSeparator
    Sheets("Data").[A:G].ClearContents
    sfile = Dir(myPath & "*.xlsx")
    Do While sfile <> ""
        Set wbk = Workbooks.Open(myPath & sfile, ReadOnly:=True)
        a = wbk.Sheets("Summary").UsedRange.Columns("A:G").Value
        wbk.Close savechanges:=True
        With Sheets("Data")
            lr = .Cells(Rows.Count, "b").End(xlUp).Row
            If lr = 1 Then
                .Cells(lr, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
            Else
                .Cells(lr + 1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
            End If
        End With
        sfile = Dir()
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Now
(looping through the files but only copying data from one file. )?
all the file located in the directory mentioned in "D6" extensions should be "xlxs"
Tested ok in Here
 
Upvote 0
mohadin said:
Well
In This case ( active x button in a sheet named "Dashboard" )
VBA Code: 
Sub Bobstar2()
    Dim wbk As Workbook
    Dim a, MyFiles As Variant
    Dim lr, i As Double
    Dim myPath, sfile As Variant
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    myPath = Range("D6") & Application.PathSeparator
    Sheets("Data").[A:G].ClearContents
    sfile = Dir(myPath & "*.xlsx")
    Do While sfile <> ""
        Set wbk = Workbooks.Open(myPath & sfile, ReadOnly:=True)
        a = wbk.Sheets("Summary").UsedRange.Columns("A:G").Value
        wbk.Close savechanges:=True
        With Sheets("Data")
            lr = .Cells(Rows.Count, "b").End(xlUp).Row
            If lr = 1 Then
                .Cells(lr, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
            Else
                .Cells(lr + 1, 1).Resize(UBound(a, 1), UBound(a, 2)) = a
            End If
        End With
        sfile = Dir()
    Loop
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Now
(looping through the files but only copying data from one file. )?
all the file located in the directory mentioned in "D6" extensions should be "xlxs"
Tested ok in Here
Click to expand...
Thanks alot. This is now working perfectly fine. Much appreciated.
 
Upvote 0
You are very well come
And thank you for the feedback
Be happy
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
Open workbooks in folder and run Macro in each book
Replies
7
Views
385
glynn1969
G
T
  • Question
Loop through folder and copy data into master spreadsheet
Replies
2
Views
287
TaskMaster
T
P
  • Question
VBA to import multilpe xml files
Replies
1
Views
58
PippaThePointer
P
A
  • Question
Find value from one workbook in another
Replies
4
Views
252
AndyEd
A
S
  • Question
VBA to loop through sheets and copy to new workbook including the pivot tab
Replies
0
Views
205
simont1975
S

Forum statistics

Threads
1,215,193
Messages
6,123,560
Members
449,108
Latest member
rache47

Share this page

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
Back
Top