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
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