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.

 

[Osmio]

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

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?

 

[maabadi]

Please upload example file for source.

 

[chajam]

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

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]

I think you add macro under personal.xlsb modules not activesheet modules at VBA window.

 

[AmateurVBAUser]

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]

you only need select folder, and don't need to open folder.

 

[AmateurVBAUser]

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]

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

 

[hartsie]

What should I modify with the VBA if my folder selection doesn't seem to recognize any files? I see in the finder folder that "no items match your search." When I select the folder containing my excel files, nothing is happening. Thank you for your time.

 

[Nuppu]

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)?

I've the same issue... In my case, data is not same in all sheets... the headers are same but not in order... i want same sheet from all workbooks which is Raw