Merging Excel Sheets: List of names with different variables in different sheets, list of names not perfect overlap

Sub CollateData()
    
    Dim ws As Worksheet
    Dim DicPeople As Object
    Dim DicPerson As Object
    Dim DicAttributes As Object
    Dim LastR As Long
    Dim r As Long
    Dim LastC As Long
    Dim c As Long
    Dim arr As Variant
    Dim PersonName As String
    Dim AttributeKey As String
    Dim AttributeValue As String
    Dim Attributes As Variant
    Dim People As Variant
    
    ' This dictionary holds all of the people
    Set DicPeople = CreateObject("Scripting.Dictionary")
    DicPeople.CompareMode = vbTextCompare

    ' This dictionary holds the various attributes stored on the different worksheets
    Set DicAttributes = CreateObject("Scripting.Dictionary")
    DicAttributes.CompareMode = vbTextCompare
    
    ' Loop through each worksheet
    For Each ws In ThisWorkbook.Worksheets
        With ws
            ' Determine last row and last column populated on worksheet
            LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
            LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column

            ' Array holds the data from the worksheet
            arr = .Range(.Cells(1, 1), .Cells(LastR, LastC)).Value

            ' Loop through the array and process each person in the worksheet
            For r = 2 To LastR
                PersonName = arr(r, 1)

                ' If we haven't seen this person yet, create a dictionary for him/her
                If Not DicPeople.Exists(PersonName) Then
                    Set DicPerson = CreateObject("Scripting.Dictionary")
                    DicPerson.CompareMode = vbTextCompare
                    DicPeople.Add PersonName, DicPerson
                End If
                Set DicPerson = DicPeople(PersonName)

                ' Loop through the columns to harvest the attributes
                For c = 2 To LastC
                    AttributeKey = arr(1, c)
                    AttributeValue = arr(r, c)
                    DicPerson.Item(AttributeKey) = AttributeValue
                    If r = 2 Then DicAttributes.Item(AttributeKey) = AttributeKey
                Next
            Next
        End With
    Next
    
    ' Create workbook for results
    Workbooks.Add
    
    ' Dump attributes and people into arrays
    Attributes = DicAttributes.Keys
    People = DicPeople.Keys

    ' Headers
    [a1].Resize(1, 1 + DicAttributes.Count).Value = Split("Name," & Join(Attributes, ","), ",")

    ' Loop through the people, and write one row per person
    For r = 0 To UBound(People)
        PersonName = People(r)
        Cells(r + 2, 1) = PersonName
        Set DicPerson = DicPeople.Item(PersonName)

        ' Loop through attributes, and if applicable write the values
        For c = 0 To UBound(Attributes)
            AttributeKey = Attributes(c)
            If DicPerson.Exists(AttributeKey) Then
                Cells(r + 2, c + 2) = DicPerson.Item(AttributeKey)
            End If
        Next
    Next
    Columns.AutoFit
    [a1].Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
    
    Set DicPerson = Nothing
    Set DicAttributes = Nothing
    Set DicPeople = Nothing
    
    MsgBox "Done"
    
End Sub

Select allOpen in new window