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