VBA Code to Combine Multiple Workbooks into one Worksheet

[BrittKnee]

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.

 

[maabadi]

1. Are your data at all workbook has same format & same columns? If yes, please tell range of data ( column names)
2. If you want only one sheet at each workbook?
3. If all is in same sheet name what is sheet name?
4. What is your header row( or rows if more than one)?

 

[BrittKnee]

1. Yes. All data in each workbook is the same
2. I have a master workbook (Combine_Susp_Qry_Results.xlsx) and would need the data from each workbook copy and pasted into that worksheet
3. Each worksheet does have the same name (Export Worksheet)
4. The header row is the same as the Column Names in #1

I have attached the image of the headers in the individual workbooks and Combine_Susp_Qry_Results.xlsx

 

[maabadi]

I didn't see image.
Try this macro at Master workbook & report if you see problem:
With this Macro:
1. Select folder Name that has excel files (select folder but don't open it)
2. Change Sheet1 at code to your sheet name has data at each excel sheet, If I right it should be : Export Worksheet
3. if you want use Macro Later, Save file as Macro-Enabled Workbook (.xlsm)

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
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
Lc = Cells(1, Columns.Count).end(xltoLeft).Column
IF Lr=1 Then
Range(xWS.Cells(1, 1), xWS.Cells(Range("A" & Rows.Count).End(xlUp).Row, Lc).Copy  DestSheet.Range("A1")
Else
Range(xWS.Cells(2, 1), xWS.Cells(Range("A" & Rows.Count).End(xlUp).Row, 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

 

[BrittKnee]

Thanks! I am receiving a compile error with the part of the code below. I have tried to find the solution and am having an issue. Thanks!

Range(xWS.Cells(1, 1), xWS.Cells(Range("A" & Rows.Count).End(xlUp).Row, Lc).Copy DestSheet.Range("A1")
Else
Range(xWS.Cells(2, 1), xWS.Cells(Range("A" & Rows.Count).End(xlUp).Row, Lc).Copy DestSheet.Range("A" & Lr + 1)

 

[maabadi]

1. Are you chane sheet name to your sheet names at source files ( Sheet1 to your sheet name)
Please Tell exact which line show yellow when see error.
Try this:

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

 

[BrittKnee]

This is what happens when I run it. I did change Sheet1 to "Export Worksheet" Thanks for your help!

 

[maabadi]

You don't need to change FolderPath.
Only use my format to select folder.
If you see error again, Please upload two source example file to I see & check problems.
Upload them at free hosting site e.g. www.dropbox.com or GoogleDrive & Insert Link here.

 

[maabadi]

Sorry my fault. First change Sheet1 at code to your sheet name then use this macro:

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

 

[Osmio]

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?