Public Sub subMergeTables()
Dim arr() As Variant
Dim objTable1 As Object
Dim objTable2 As Object
Dim Q As String
Dim WsResults As Worksheet
Dim WsMerged As Worksheet
Dim objMerged As ListObject
' **** Change the table names in the next two lines as appropriate. ****
Set objTable1 = Application.Range("tblOne").ListObject
Set objTable2 = Application.Range("tblTwo").ListObject
Call subCreateSheet("MergedData")
Set WsMerged = Worksheets("MergedData")
WsMerged.Activate
Q = Chr(34)
With WsMerged
.Range("A1").Resize(1, 4).Value = Array("Name 1", "Description", "b/f", "c/f")
.Range("A2").Formula2 = "=LET(d,VSTACK(HSTACK(" & objTable1.Name & _
",TRANSPOSE(TEXTSPLIT(REPT(" & Q & "b/f," & Q & ",ROWS(" & objTable1.Name & "))," _
& Q & "," & Q & ",,TRUE))),HSTACK(" & objTable2.Name & ",TRANSPOSE(TEXTSPLIT(REPT(" & _
Q & "c/f," & Q & ",ROWS(" & objTable2.Name & "))," & Q & "," & Q & ",,TRUE)))),d)"
With .Range("A1").CurrentRegion
.Value = .Value
End With
Set objMerged = .ListObjects.Add(xlSrcRange, WsMerged.Range("A1").CurrentRegion, , xlYes)
.ListObjects(1).Name = "tblMergedData"
.Range("A1").AutoFilter
.Range("F1").Resize(1, 4).Value = Array("Name 1", "Description", "b/f", "c/f")
arr = Evaluate("=UNIQUE(VSTACK(CHOOSECOLS(tblOne,{1,2}),CHOOSECOLS(tblTwo,{1,2})))")
.Range("F2").Resize(UBound(arr), 2).Value = arr
.Range("H2").Formula2 = "=LET(s,SUMIFS(tblMergedData[b/f],tblMergedData[Name 1],F2:F" & _
UBound(arr) + 1 & ",tblMergedData[Description],G2:G" & UBound(arr) + 1 & _
",tblMergedData[c/f],H1),IF(s>0,s," & Q & Q & "))"
.Range("I2").Formula2 = "=LET(s,SUMIFS(tblMergedData[b/f],tblMergedData[Name 1],F2:F" & _
UBound(arr) + 1 & ",tblMergedData[Description],G2:G" & UBound(arr) + 1 & _
",tblMergedData[c/f],I1),IF(s>0,s," & Q & Q & "))"
With .Range("F1").CurrentRegion
.Value = .Value
End With
With .Cells
.RowHeight = 24
.Font.Size = 14
.Font.Name = "Arial"
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.IndentLevel = 1
.EntireColumn.AutoFit
End With
End With
MsgBox "Tables merged and results calculated.", vbOKOnly, "Confirmation"
End Sub
Private Sub subCreateSheet(ByVal strSheet As String)
Dim WsActive As Worksheet
Set WsActive = ActiveSheet
If Evaluate("isref('" & strSheet & "'!A1)") Then
Worksheets(strSheet).Cells.Clear
Else
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = strSheet
End If
WsActive.Activate
End Sub