Compare More Than Two Worksheets and Reconcile Differences

Option Explicit
Option Compare Text


Sub test()
    Dim ws As Worksheet, a, i As Long, ii As Long
    Dim txt As String, b, n As Long, t As Long
    Const FixedCols As Long = 3
    ReDim b(1 To 100000, 1 To FixedCols): n = 1
    b(1, 1) = "Name": b(1, 2) = "Product": b(1, 3) = "ID Number"
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each ws In Worksheets
            If ws.Name Like "*Company *" Then
                t = t + 1
                ReDim Preserve b(1 To UBound(b, 1), 1 To FixedCols + t)
                b(1, UBound(b, 2)) = ws.Name
                a = ws.Range("a3").CurrentRegion.Value
                For i = 2 To UBound(a, 1)
                    For ii = 1 To FixedCols
                        txt = txt & Chr(2) & a(i, ii)
                    Next
                    If Not .exists(txt) Then
                        n = n + 1: .Item(txt) = n
                        For ii = 1 To FixedCols
                            b(n, ii) = a(i, ii)
                        Next
                    End If
                    b(.Item(txt), UBound(b, 2)) = a(i, 4): txt = ""
                Next
            End If
        Next
    End With
    With Sheets("differences").Cells(1).Resize(n, UBound(b, 2))
        .CurrentRegion.ClearContents
        .Value = b
        .Rows(n + 1).Cells(1, FixedCols + 1).Resize(, .Columns.Count _
        - FixedCols + 1).Formula = "=sum(r2c:r[-1]c)"
        .Cells(1, .Columns.Count + 1).Value = "Difference"
        .Columns(.Columns.Count + 1).Offset(1).Resize(n - 1).Formula = _
        "=rc" & FixedCols + 1 & "-sum(rc" & FixedCols + 2 & ":rc[-1])"
        .CurrentRegion.Columns.AutoFit: .Parent.Select
    End With
End Sub