Macros - Merge Multiple Workbooks with common worksheet names

[Poppaby]

Hi all

I have a folder with 20 workbooks. Each workbook has roughly 14 tabs. The tab naming is consistent across all workbooks, however some workbooks might not have all tabs (some have 12, 10,14 etc)

I would like a macros to merge all the workbooks into a single workbook, combining all the tabs with similar names into one tab with that name in the workbook, with the column headers being used once if possible.

Any help you can provide would be greatly appreciated

Dave

 

[Zot]

Helpers need to know what happened to content of each tab of similar name when they are merged together. How data in each tab looks like if they are to be cascaded or added.

 

[Poppaby]

Thank you for coming back to me so quickly

example:

for each workbook with a tab called "workers" I would like all those tabs merged into a single tab called "workers" with the contents of all those tabs combined in the tab "workers". SO if there are 20 rows in one "workers" tab, 12 in another and 15 in another, the final tab will have 47 rows.

 

[Poppaby]

As if I was cut/paste all info across multiple tabs of the same name into a single tab to create a database.

 

[Zot]

This is a simplified code. The Target workbook (where to code reside) need to be constructed with all the sheet names that might exist in all the other workbooks that you are going to extract data from (I refer as source workbooks). The source workbooks do not have to have all the sheets existed in the Target workbook though.

Sub ConsolidateData()

Dim LastRowTarget As Long
Dim strExt As String, strTab As String, ArryTab() As String
Dim LastSourceCell As Range
Dim TabName As Variant
Dim wsSource As Worksheet, wsTarget As Worksheet
Dim wbSource As Workbook, wbTarget As Workbook

' Name all Tabs existed in workbook Target here separated by space
strTab = "Sheet1 Sheet2 Sheet3"

ArryTab = Split(strTab)

' Set your folder path nad file extension here
Const strPath As String = "C:\Test\"
strExt = Dir("*.xlsx")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wbTarget = ActiveWorkbook

On Error Resume Next
ChDir strPath
    
Do While strExt <> ""
    Set wbSource = Workbooks.Open(strPath & strExt)
    For Each TabName In ArryTab
        If SheetExists(wbSource, TabName) Then
            Set wsTarget = wbTarget.Sheets(TabName)
            Set wsSource = wbSource.Sheets(TabName)
            If WorksheetFunction.CountA(wsTarget.Cells) = 0 Then
                LastRowTarget = 1
            Else
                LastRowTarget = wsTarget.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
            End If
            Set LastSourceCell = wsSource.Cells.SpecialCells(xlCellTypeLastCell)
        Else
            Exit For
        End If
        wsSource.Range("A1", LastSourceCell).Copy wsTarget.Range("A" & LastRowTarget)
        wbSource.Close False
    Next
    strExt = Dir
Loop

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
On Error GoTo 0
End Sub

Function SheetExists(wb As Workbook, FindSheet As Variant) As Boolean

SheetExists = False
For Each Sheet In wb.Worksheets
    If FindSheet = Sheet.Name Then
        SheetExists = True
        Exit Function
    End If
Next Sheet

End Function