VBA Code to Combine Multiple Workbooks into one Worksheet

BrittKnee

New Member
Joined
Dec 4, 2017
Messages
37
Hi! I want to combine data in multiple worksheets into one master worksheet in a separate workbook. All files are located in the same folder, so it would just need to loop to copy/paste into the master workbook's combined worksheet. I would like to house the macro in a separate workbook. Any help is appreciated. Below are screenshots of the folder with all of the workbooks and the Master Workbook. Files export_1-2 through export_T need to be copied into the worksheet named Combined_Results in Combine_Susp_Qry_Results.xlsx Any help is appreciated.

1622044602344.png
1622044466410.png
 

Attachments

  • 1622044411912.png
    1622044411912.png
    17.3 KB · Views: 39

Osmio

New Member
Joined
Jul 15, 2021
Messages
2
Office Version
  1. 2016
Platform
  1. Windows
Sorry my fault. First change Sheet1 at code to your sheet name then use this macro:
VBA Code:
Sub ImportFiles()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
Debug.Print DestSheet.Name
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
  
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
Lr2 = xWS.Range("A" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
If Lr = 1 Then
Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("A1")
Else
Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("A" & Lr + 1)
End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Thank you so much maabadi for this code. It was exactly what I'm looking for as well. I know this post is a little bit old. But I would like to ask, what if the data table I need to compile on each file starts at B5?
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
2,681
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Please upload example file for source.
 

chajam

New Member
Joined
Oct 8, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
Sorry my fault. First change Sheet1 at code to your sheet name then use this macro:
VBA Code:
Sub ImportFiles()
Dim strPath As String, xStrPath As String, xStrName As String, xStrFName As String
Dim xWS As Worksheet, xTWB As Workbook, DestSheet As Worksheet, FileName As String
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, sItem As String
Dim FolderPath As String, fldr As FileDialog, Lr As Long, Lc As Long, Lr2 As Long
On Error Resume Next
Set xTWB = ThisWorkbook
Set DestSheet = xTWB.ActiveSheet
Debug.Print DestSheet.Name
  Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    FolderName = sItem
    Set fldr = Nothing
    FolderPath = FolderName & "\"
  
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
Set Sh1 = ActiveWorkbook.Sheets("Sheet1")
xStrName = Sh1.Name
For Each xWS In ActiveWorkbook.Sheets
If xWS.Name = xStrName Then
Lr = DestSheet.Range("A" & Rows.Count).End(xlUp).Row
Lr2 = xWS.Range("A" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
If Lr = 1 Then
Range(xWS.Cells(1, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("A1")
Else
Range(xWS.Cells(2, 1), xWS.Cells(Lr2, Lc)).Copy DestSheet.Range("A" & Lr + 1)
End If
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Hi @maabadi, thanks for this code, it's exactly what I was looking for. now, when I run this macro, the result data is saved in my personal.xlsb file. how can I make this macro run in my active worksheet?
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
2,681
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I think you add macro under personal.xlsb modules not activesheet modules at VBA window.
 

AmateurVBAUser

New Member
Joined
Oct 28, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hi,

I have a question regarding this. I tried using this macro. It is able to open the files in the folder but it doesn't seem to copy the data so I always just end up with an empty file. Is there something else I need to modify?

Thank you.
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
2,681
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
you only need select folder, and don't need to open folder.
 

AmateurVBAUser

New Member
Joined
Oct 28, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi maabadi,

That's what I do. I just select the folder that contains the files but I don't open it.

Thank you.
 

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
2,681
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
1. Please ask your question as new thread if condition is different and describe with details.
2. what is your data range, I use column A to find Last row at each file, if your files don't have data at column A you should change it.
3. what is your sheet name at each file to copy? If is Sheet1 No problem
 
Learn Excel from Bill Jelen

Understanding data is crucial, and the easiest place to start is with Microsoft Excel.

Forum statistics

Threads
1,151,589
Messages
5,765,308
Members
425,272
Latest member
Umba

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