Option Explicit
Const MergeSheetName As String = "Merged Data"
Sub MergeSheets()
Dim dicMergeData As Object
Dim lEndRow As Long
Dim lEndCol As Long
Dim lColPtr As Long
Dim lRowPtr As Long
Dim lMergePtr As Long
Dim rFrom As Range
Dim rTo As Range
Dim sKey As String
Dim sSearchKey As String
Dim sSearchItem As String
Dim vaCurSheetData As Variant
Dim vaMergeData As Variant
Dim wsCur As Worksheet
Dim wsMerge As Worksheet
On Error Resume Next
dicMergeData.RemoveAll
Set dicMergeData = Nothing
On Error GoTo 0
Set dicMergeData = CreateObject("Scripting.Dictionary")
vaMergeData = False
For Each wsCur In ThisWorkbook.Worksheets
If wsCur.Name <> MergeSheetName Then
If wsCur.Range("A1").Value = "Name" Then
Application.StatusBar = "Processing worksheet '" & wsCur.Name & "'"
With wsCur
If IsArray(vaMergeData) = False Then
lEndCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
End If
lEndRow = .Cells(.Rows.Count, 1).End(xlUp).Row
vaCurSheetData = .Range("A1").Resize(lEndRow, lEndCol).Value
If IsArray(vaMergeData) = False Then
ReDim vaMergeData(1 To lEndCol + 1, 1 To 1)
lMergePtr = 1
vaMergeData(1, 1) = "Sort Key"
For lColPtr = 1 To lEndCol
vaMergeData(lColPtr + 1, 1) = vaCurSheetData(1, lColPtr)
Next lColPtr
End If
For lRowPtr = 2 To lEndRow
sKey = NormaliseString(Stringx:=CStr(vaCurSheetData(lRowPtr, 1)))
sSearchKey = NormaliseString(Stringx:=CStr(vaCurSheetData(lRowPtr, 2)))
If dicMergeData.exists(sSearchKey) = True Then
sKey = dicMergeData.Item(sSearchKey)
Else
dicMergeData.Add Key:=sSearchKey, Item:=sKey
End If
lMergePtr = lMergePtr + 1
ReDim Preserve vaMergeData(1 To lEndCol + 1, 1 To lMergePtr)
vaMergeData(1, lMergePtr) = sKey
For lColPtr = 1 To lEndCol
vaMergeData(lColPtr + 1, lMergePtr) = vaCurSheetData(lRowPtr, lColPtr)
Next lColPtr
Next lRowPtr
End With
End If
End If
Next wsCur
On Error Resume Next
Set wsMerge = Nothing
Set wsMerge = Sheets(MergeSheetName)
On Error GoTo 0
If wsMerge Is Nothing Then
With ThisWorkbook
Set wsMerge = .Sheets.Add(before:=.Sheets(1))
wsMerge.Name = MergeSheetName
End With
End If
Application.StatusBar = "Writing Results to worksheet '" & wsMerge.Name & "'"
wsMerge.Cells.ClearContents
With wsMerge
lEndRow = UBound(vaMergeData, 2)
lEndCol = UBound(vaMergeData, 1)
.Range("A1").Resize(lEndRow, lEndCol).Value = WorksheetFunction.Transpose(vaMergeData)
.Range("A1").Resize(1, lEndCol).Font.Bold = True
.Columns(GetColLetter(1, lEndCol)).EntireColumn.AutoFit
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A2:A" & lEndRow), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("B2:B" & lEndRow), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=Range("C2:C" & lEndRow), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With wsMerge.Sort
.SetRange wsMerge.Range("A1").Resize(lEndRow, lEndCol)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Application.StatusBar = False
End Sub
Private Function NormaliseString(ByVal Stringx As String) As String
Dim lPtr As Long
Dim sCur As String
Dim sResult As String
sResult = ""
For lPtr = 1 To Len(Stringx)
sCur = LCase$(Mid$(Stringx, lPtr, 1))
If sCur <> UCase$(sCur) _
Or IsNumeric(sCur) Then
sResult = sResult & sCur
End If
Next lPtr
NormaliseString = sResult
End Function
Private Function GetColLetter(ByVal Col1 As Long, _
Optional Col2 As Long = 0) As String
Dim sCol As String
sCol = ThisWorkbook.Sheets(1).Cells(1, Col1).Address(True, False)
GetColLetter = Left$(sCol, InStr(sCol, "$") - 1)
If Col2 > 0 Then
sCol = ThisWorkbook.Sheets(1).Cells(1, Col2).Address(True, False)
GetColLetter = GetColLetter & ":" & Left$(sCol, InStr(sCol, "$") - 1)
End If
End Function
