Merge Multiple Worksheets into One

[Rasm]

I am wanting to merge multiple worksheets - essentially they have the same structure - except some sheets may have extra columns that are missing in other sheets. My column headers are right now in row 3 - but lets assume the header is in row 1. Essentially I want my combined sheet to have all headers in the order they appear - so if all sheets have same column header in col A - that is the common header. If the next header in sheet #1 is Month but Year in sheet #2 then my common header for Col B is Month and Col C is year - and so on. If a sheet is missing data for say the column Months - I simply leave those cells blank.

I was just wondering if anybody already has a piece of code - trying to save time.

[Admin]

Hi Rasm,

Try this.

Sub kTest()
    
    Dim wksMaster       As Worksheet
    Dim i               As Long
    Dim p               As Long
    Dim n   As Long, q  As Long
    Dim ka, k(), c      As Long
    Dim Hdr(), m        As Long
    Dim w, dic          As Object
    Dim strConcat       As String
    Dim strShtName      As String
    
    
    On Error Resume Next
    Set wksMaster = Worksheets("Master")
    On Error GoTo 0
    Application.ScreenUpdating = 0
    
    If wksMaster Is Nothing Then
        Set wksMaster = Worksheets.Add
        wksMaster.Name = "Master"
    End If
    
    m = Worksheets.Count
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
    
    For i = 1 To m
        strShtName = Worksheets(i).Name
        If strShtName <> wksMaster.Name Then
            w = Worksheets(i).UsedRange.Rows(1) 'Header row
            q = q + Worksheets(i).UsedRange.Rows.Count - 1
            For c = 1 To UBound(w, 2)
                n = n + 1
                strConcat = i & strShtName & "|" & c & "|" & w(1, c)
                ReDim Preserve Hdr(1 To n)
                Hdr(n) = strConcat
            Next
        End If
    Next
    
    With wksMaster
        .UsedRange.Clear
        With .Range("a1")
            .Resize(, 3).Value = [{"SheetName","HdrIndex","Header"}]
            .Offset(1).Resize(n).Value = Application.Transpose(Hdr)
            .Offset(1).Resize(n).TextToColumns Destination:=.Cells(2, 1), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
                :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
                TrailingMinusNumbers:=True
            .Resize(n + 1, 3).Sort .Cells(2, 2), 1, .Cells(2, 1), , 1, Header:=xlYes
            Erase Hdr
            w = .Offset(1).Resize(n, 3)
            For i = 1 To n
                If Not dic.exists(w(i, 3)) Then
                    p = p + 1
                    dic.Add w(i, 3), p
                End If
            Next
        End With
        .UsedRange.Clear
    End With
    n = 0
    ReDim k(1 To q, 1 To p)
    For i = 1 To m
        strShtName = Worksheets(i).Name
        If strShtName <> wksMaster.Name Then
            ka = Worksheets(i).UsedRange
            For p = 2 To UBound(ka, 1)
                n = n + 1
                For c = 1 To UBound(ka, 2)
                    q = dic.Item(ka(1, c))
                    k(n, q) = ka(p, c)
                Next
            Next
            Erase ka
        End If
    Next
    If n Then
        With wksMaster.Range("a1")
            .Resize(, dic.Count).Value = dic.keys
            .Offset(1).Resize(n, dic.Count).Value = k
        End With
    End If
    Application.ScreenUpdating = 1
                     
End Sub

[Rasm]

cool - I have some other stuff to finish - then I try this - thanks