Transpose data from one column based on criteria of a different column with VBA Arrays

Try change to

Sub test()
    Dim a, e, s, i As Long, txt As String, maxCol As Long, n As Long, t As Long
    a = Sheets("contracts").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                .Item(a(i, 1)).CompareMode = 1
            End If
            txt = Join(Array(a(i, 2), a(i, 3)), Chr(2))
            .Item(a(i, 1))(txt) = a(i, 2)
            maxCol = Application.Max(maxCol, .Item(a(i, 1)).Count + 1)
        Next
        ReDim a(1 To .Count, 1 To maxCol)
        For Each e In .keys
            n = n + 1: a(n, 1) = e: t = 1
            For Each s In .Item(e)
                t = t + 1: a(n, t) = .Item(e)(s)
            Next
        Next
    End With
    With Sheets.Add.Cells(1).Resize(n, maxCol)
        .Value = a
        If maxCol > 2 Then
            .Cells(1, 2).Value = .Cells(1, 2).Value & 1
            .Cells(1, 2).AutoFill .Cells(1, 2).Resize(, maxCol - 2)
        End If
        .Columns.AutoFit
    End With
End Sub