Convert a list of IDs, puchases and teaches so that one unique id appears per row while others variables populate the colums behind

[Okomomo]

Hi everyone

I'm trying to design a tool with vba that converts one table to another where one unique id appears per row while others variables populate the colums behind.
Thanks for your help

I have:

ID	Purchase	Teaches	Purchase quantity	Cost
111	banana	Walmart	1	2
115	sugar	aldi	2	6
112	plums	costco	3	4
111	eggs	kroger	6	7
113	mango	kroger	7	9
112	meats	walmart	9	10
111	bread	walmart	1	11

I want this:

 

[Zot]

I think your data and your result is not tally. Causing me thinking it was my error ?
Data show for 113, Teaches is Kroger but your Result shows that the data is Walmart
See if this works:

Option Compare Text
Sub test()

Dim x As Variant
Dim strSearch As String
Dim nRow As Long, nCount As Long, colOff As Long, ColMax As Long
Dim cell As Range, Title As Range
Dim rngData As Range, rngTitle As Range
Dim rngSearch As Range, rngFound As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim dData As Object

Set dData = CreateObject("Scripting.Dictionary")

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

Set rngTitle = ws1.Range("B1", "D1")
Set rngData = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngData
    If Not dData.Exists(cell.Value2) Then
        dData.Add cell.Value2, 1
    Else
        dData(cell.Value2) = dData(cell.Value2) + 1
    End If
    If dData(cell.Value2) > ColMax Then ColMax = dData(cell.Value2)
Next

' Setup Sheets(2)
With ws2.Range("A1")
    .Value = "Registration Number"
    For Each Title In rngTitle
        For nCount = 1 To ColMax
            colOff = colOff + 1
            .Offset(, colOff) = Title & " " & nCount
        Next
    Next
    .Offset(, colOff + 1) = "Total Purchase"
    .Offset(, colOff + 2) = "Cost Total"
    .Offset(, colOff + 3) = "Purchase Quantity From Walmart"
End With

Set rngSearch = ws2.Range("B1", ws2.Cells(1, Columns.Count).End(xlToLeft))
nRow = 1
For Each Key In dData
    nRow = nRow + 1
    For Each cell In rngData
        If Key = cell Then
            ws2.Range("A" & nRow) = Key
            For Each Title In rngTitle
                nCount = ColMax
                x = ws1.Cells(cell.Row, Title.Column)
                strSearch = Title & " " & nCount
SearchAgain:
                Set rngFound = rngSearch.Find(strSearch, , xlValues, xlWhole, 1, 1, 0)
                If ws2.Cells(nRow, rngFound.Column) = 0 And Not rngFound = Title & " 1" Then
                    nCount = nCount - 1
                    strSearch = Title & " " & nCount
                    GoTo SearchAgain
                ElseIf Not ws2.Cells(nRow, rngFound.Column) = 0 Then
                    Set rngFound = rngFound.Offset(0, 1)
                    ws2.Cells(nRow, rngFound.Column) = x
                Else
                    ws2.Cells(nRow, rngFound.Column) = x
                End If
                If x = "Walmart" Then
                    Set rngFound = rngSearch.Find("Purchase Quantity From Walmart", , xlValues, xlWhole, 1, 1, 0)
                    ws2.Cells(nRow, rngFound.Column) = ws2.Cells(nRow, rngFound.Column) + ws1.Range("D" & cell.Row)
                End If
            Next
            Set rngFound = rngSearch.Find("Cost Total", , xlValues, xlWhole, 1, 1, 0)
            ws2.Cells(nRow, rngFound.Column) = ws2.Cells(nRow, rngFound.Column) + ws1.Range("E" & cell.Row)
        End If
    Next
Next

Set rngFound = rngSearch.Find("Total Purchase", , xlValues, xlWhole, 1, 1, 0)
ws2.Range(Cells(2, rngFound.Column), Cells(dData.Count + 1, rngFound.Column)).Formula = _
    "= SUM(" & ws2.Cells(2, rngFound.Column).Offset(0, -ColMax).Address(0, 0) & ":" & ws2.Cells(2, rngFound.Column).Offset(0, -ColMax + 2).Address(0, 0) & ")"

End Sub

 

[Okomomo]

I think your data and your result is not tally. Causing me thinking it was my error ?
Data show for 113, Teaches is Kroger but your Result shows that the data is Walmart
See if this works:

Option Compare Text
Sub test()

Dim x As Variant
Dim strSearch As String
Dim nRow As Long, nCount As Long, colOff As Long, ColMax As Long
Dim cell As Range, Title As Range
Dim rngData As Range, rngTitle As Range
Dim rngSearch As Range, rngFound As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim dData As Object

Set dData = CreateObject("Scripting.Dictionary")

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

Set rngTitle = ws1.Range("B1", "D1")
Set rngData = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))

For Each cell In rngData
    If Not dData.Exists(cell.Value2) Then
        dData.Add cell.Value2, 1
    Else
        dData(cell.Value2) = dData(cell.Value2) + 1
    End If
    If dData(cell.Value2) > ColMax Then ColMax = dData(cell.Value2)
Next

' Setup Sheets(2)
With ws2.Range("A1")
    .Value = "Registration Number"
    For Each Title In rngTitle
        For nCount = 1 To ColMax
            colOff = colOff + 1
            .Offset(, colOff) = Title & " " & nCount
        Next
    Next
    .Offset(, colOff + 1) = "Total Purchase"
    .Offset(, colOff + 2) = "Cost Total"
    .Offset(, colOff + 3) = "Purchase Quantity From Walmart"
End With

Set rngSearch = ws2.Range("B1", ws2.Cells(1, Columns.Count).End(xlToLeft))
nRow = 1
For Each Key In dData
    nRow = nRow + 1
    For Each cell In rngData
        If Key = cell Then
            ws2.Range("A" & nRow) = Key
            For Each Title In rngTitle
                nCount = ColMax
                x = ws1.Cells(cell.Row, Title.Column)
                strSearch = Title & " " & nCount
SearchAgain:
                Set rngFound = rngSearch.Find(strSearch, , xlValues, xlWhole, 1, 1, 0)
                If ws2.Cells(nRow, rngFound.Column) = 0 And Not rngFound = Title & " 1" Then
                    nCount = nCount - 1
                    strSearch = Title & " " & nCount
                    GoTo SearchAgain
                ElseIf Not ws2.Cells(nRow, rngFound.Column) = 0 Then
                    Set rngFound = rngFound.Offset(0, 1)
                    ws2.Cells(nRow, rngFound.Column) = x
                Else
                    ws2.Cells(nRow, rngFound.Column) = x
                End If
                If x = "Walmart" Then
                    Set rngFound = rngSearch.Find("Purchase Quantity From Walmart", , xlValues, xlWhole, 1, 1, 0)
                    ws2.Cells(nRow, rngFound.Column) = ws2.Cells(nRow, rngFound.Column) + ws1.Range("D" & cell.Row)
                End If
            Next
            Set rngFound = rngSearch.Find("Cost Total", , xlValues, xlWhole, 1, 1, 0)
            ws2.Cells(nRow, rngFound.Column) = ws2.Cells(nRow, rngFound.Column) + ws1.Range("E" & cell.Row)
        End If
    Next
Next

Set rngFound = rngSearch.Find("Total Purchase", , xlValues, xlWhole, 1, 1, 0)
ws2.Range(Cells(2, rngFound.Column), Cells(dData.Count + 1, rngFound.Column)).Formula = _
    "= SUM(" & ws2.Cells(2, rngFound.Column).Offset(0, -ColMax).Address(0, 0) & ":" & ws2.Cells(2, rngFound.Column).Offset(0, -ColMax + 2).Address(0, 0) & ")"

End Sub

It’s perfect, thanks so much