Merging Workbooks side by side instead of top to bottom

[Mr_Phil]

I have a need to merge workbooks. The unusual item is that since the column headers are not the same I need to merge it from left to right instead of top to bottom.

Currently my merge looks like a stack of pancakes because the raw data was for one person at a time.

WB1
WB2
WB3

The vendor changed the output and moved the person name to be a column header. That means each report can be for a dozen people instead of a dozen individual reports. But, that means I need to stack them side by side. From there I can power query it to clean up and format.

WB1WB2WB3

I believe I got this code from this forum a couple of years ago. I've highlighted the bit that I think is responsible for the current stack arrangement.

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
    Call NewWorkBook
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
 
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
 
            Set wbkCurBook = ActiveWorkbook
 
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
 
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
 
                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                  [COLOR=rgb(226, 80, 65)][B]  wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)[/B][/COLOR]
                Next
 
                wbkSrcBook.Close SaveChanges:=False
 
            Next
 
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
 
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
    Call BackfillCleanUpWithName
End Sub

As always, thank you for taking the time to read this. Any help/pointers truly appreciated.

 

[John_w]

Try this:

Sub MergeExcelFiles()
    Dim fnameList As Variant, fnameCurFile As Variant
    Dim countFiles As Long, countSheets As Long
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook As Workbook, wbkSrcBook As Workbook
    Dim destCell As Range
    
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If IsArray(fnameList) Then
    
        Call NewWorkbook
        countFiles = 0
        countSheets = 0
    
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        
        Set wbkCurBook = ActiveWorkbook
        Set destCell = wbkCurBook.Worksheets(1).Range("A1")
        
        For Each fnameCurFile In fnameList
            countFiles = countFiles + 1
        
            Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
        
            For Each wksCurSheet In wbkSrcBook.Worksheets
                wksCurSheet.Range("A1").CurrentRegion.Copy destCell
                Set destCell = destCell.Offset(, wksCurSheet.Range("A1").CurrentRegion.Columns.Count)
                countSheets = countSheets + 1
            Next
        
            wbkSrcBook.Close SaveChanges:=False
        
        Next
        
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
        
        MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
    Call BackfillCleanUpWithName
End Sub

 

[Mr_Phil]

Try this:

Sub MergeExcelFiles()
    Dim fnameList As Variant, fnameCurFile As Variant
    Dim countFiles As Long, countSheets As Long
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook As Workbook, wbkSrcBook As Workbook
    Dim destCell As Range
   
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If IsArray(fnameList) Then
   
        Call NewWorkbook
        countFiles = 0
        countSheets = 0
   
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
       
        Set wbkCurBook = ActiveWorkbook
        Set destCell = wbkCurBook.Worksheets(1).Range("A1")
       
        For Each fnameCurFile In fnameList
            countFiles = countFiles + 1
       
            Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
       
            For Each wksCurSheet In wbkSrcBook.Worksheets
                wksCurSheet.Range("A1").CurrentRegion.Copy destCell
                Set destCell = destCell.Offset(, wksCurSheet.Range("A1").CurrentRegion.Columns.Count)
                countSheets = countSheets + 1
            Next
       
            wbkSrcBook.Close SaveChanges:=False
       
        Next
       
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
       
        MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
    Call BackfillCleanUpWithName
End Sub

That's the ticket! Worked Great. From there I used power query to unpivot all but the first two columns that contain the dates and items issued. Then it was simple to filter the junk out of the rows. I truly appreciate your help.