Macro that can transpose and roll up identical items

Hello,

I need help writing a macro from scratch that can copy data from one sheet and then paste them in another sheet but with two transformations: the pasted data needs to transpose the horizontal raw data into a vertical arrangement AND roll up records that are identical. Ideally, the macro runs and updates automatically after someone hits Save or Save As on the file.

I've attached a sample Excel file of what the results should look like. Normally, I would share the macro that I've started writing as a starting point but I don't even know where to start with this particular task. Any help would be greatly appreciated.

Danny

Try this:-
Results on "Results sheet" starting "A1"

Sub MG13Nov00
Dim Rng As Range, Dn As Range, n As Long, Ray As Variant, Dic As Object
Dim K As Variant, c As Long, Rw As Long, Ac As Integer
 Ray = Sheets("Data Entry Sheet").Range("A2").CurrentRegion
    ReDim nray(1 To UBound(Ray, 1) * UBound(Ray, 2), 1 To 6)
nray(1, 1) = "Name": nray(1, 2) = "ID": nray(1, 3) = "Quantity": nray(1, 4) = "Item": nray(1, 5) = "Old Score": nray(1, 6) = "New Score"
 c = 1
For Rw = 3 To UBound(Ray, 1)
    Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
    For Ac = 4 To 8
        If Not Dic.Exists(Ray(Rw, Ac) & "," & Ray(Rw, Ac + 5)) Then
            Dic.Add Ray(Rw, Ac) & "," & Ray(Rw, Ac + 5), 1
        Else
            Dic(Ray(Rw, Ac) & "," & Ray(Rw, Ac + 5)) = Dic(Ray(Rw, Ac) & "," & Ray(Rw, Ac + 5)) + 1
        End If
    Next Ac

     For Each K In Dic.keys
         If Not K = "," Then
            c = c + 1
            nray(c, 1) = Ray(Rw, 1): nray(c, 2) = Ray(Rw, 2): nray(c, 3) = Dic(K)
            nray(c, 4) = "Challenge": nray(c, 5) = Split(K, ",")(0): nray(c, 6) = Split(K, ",")(1)
         End If
        Next K
          c = c + 1
          nray(c, 1) = Ray(Rw, 1): nray(c, 2) = Ray(Rw, 2): nray(c, 3) = Ray(Rw, 3)
          nray(c, 4) = "Badge"
  
Next Rw

With Sheets("Results Sheet").Range("A1").Resize(c, 6)
    .Value = nray
    .Columns.AutoFit
    .Borders.Weight = 2
End With
End Sub

Regards Mick

Flexible to increase/decrease of number of score columns.

Sub tset()
    Dim a, i As Long, ii As Long, ub As Long
    Dim e, s, n As Long, w, txt As String
    a = Sheets("Data Entry Sheet").Cells(1).CurrentRegion.Value
    ub = (UBound(a, 2) - 3) \ 2 + 3
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 3 To UBound(a, 1)
            If Not .Exists(a(i, 2)) Then
                Set .Item(a(i, 2)) = CreateObject("Scripting.Dictionary")
            End If
            For ii = 4 To ub
                If a(i, ii) <> "" Then
                    txt = Join(Array(a(i, ii), a(i, ub + ii - 3)), Chr(2))
                    If Not .Item(a(i, 2)).Exists(txt) Then
                        ReDim w(1 To 6)
                        w(1) = a(i, 1): w(2) = a(i, 2)
                        w(4) = Left$(a(1, 4), Len(a(1, 4)) - 1)
                        w(5) = a(i, ii): w(6) = a(i, ub + ii - 3)
                    Else
                        w = .Item(a(i, 2))(txt)
                    End If
                    w(3) = w(3) + 1
                    .Item(a(i, 2))(txt) = w
                End If
            Next
            ReDim w(1 To 6)
            w(1) = a(i, 1): w(2) = a(i, 2): w(3) = a(i, 3)
            w(4) = Left$(a(2, 3), Len(a(2, 3)) - 1)
            .Item(a(i, 2))(a(i, 3)) = w
        Next
        ReDim a(1 To UBound(a, 1) * UBound(a, 2), 1 To 6)
        For Each e In .keys
            For Each s In .Item(e).keys
                n = n + 1
                For ii = 1 To 6
                    a(n, ii) = .Item(e)(s)(ii)
                Next
            Next
        Next
    End With
    With Sheets("Results Sheet").Cells(1).Resize(, 6)
        With .CurrentRegion
            .ClearContents: .Borders.LineStyle = xlNone
        End With
        .Value = Array("Name", "ID", "Quantity", "Item", "Old Score", "New Score")
        .Rows(2).Resize(n).Value = a
        With .CurrentRegion
            .Borders.Weight = 2: .Columns.AutoFit
        End With
    End With
End Sub

Thanks Mick. This worked!