Convert table of contents to another format

[YasserKhalil]

Hello everyone
I have a range of four columns .. I need to extract unique items from both column A and column B .. and as for column C to be populated as headers and finally put suitable value in suitable place
I have attached desired results so as to be clear
Note: I can do it using pivot table but I need a solution using vba codes
Thanks advanced for help

[YasserKhalil]

Any help in this topic please?

[Leith Ross]

Hello Yasser,

The macro shown has been added to the attached workbook and has been tested. It works works with the layout in your sample workbook. If the original workbook layout is different then you may need to make some changes.



Sub ReformatData()


Dim Cell As Range
Dim Data As Variant
Dim Dict As Object
Dim Key As Variant
Dim Keys As Variant
Dim Headers As Variant
Dim j As Long
Dim k As Long
Dim n As Long
Dim RngBeg As Range
Dim RngEnd As Range
Dim Sorted As Boolean
Dim ZtoA As Boolean

j = 1

ReDim Headers(0)

' Clear any previous data.
Range("G1").CurrentRegion.ClearContents

Set Dict = CreateObject("Scripting.Dictionary")
Dict.CompareMode = vbTextCompare

Set RngBeg = Range("C2")
Set RngEnd = Cells(Rows.Count, "C").End(xlUp)

If RngEnd.Row < RngBeg.Row Then Exit Sub

' Create a list of the unique headers.
For Each Cell In Range(RngBeg, RngEnd)
Key = Trim(Cell)
If Key <> "" Then
If Not Dict.Exists(Key) Then
Dict.Add Key, 1
Headers(UBound(Headers)) = Key
ReDim Preserve Headers(UBound(Headers) + 1)
End If
End If
Next Cell

' Add ID and Name headers.
Range("G1").Resize(1, 2).Value = Array("ID", "Name")

' Add the unique headers and Sort them from A to Z.
With Range("I1").Resize(1, UBound(Headers))
.Value = Headers
.Sort Key1:=Range("I1"), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
Headers = .Value
End With

' Clear the Dictionary
Dict.RemoveAll

' Array to hold the data.
ReDim Data(1 To UBound(Headers, 2) + 2, 1 To 1)

' Create a list of IDs and Names and place totals in an array.
For Each Cell In Range(RngBeg, RngEnd).Offset(0, -2)
Key = Trim(Cell)
If Key <> "" Then
If Not Dict.Exists(Key) Then
Data(1, j) = Cell.Value ' ID
Data(2, j) = Cell.Offset(0, 1).Value ' Name
k = Application.Match(Cell.Offset(0, 2), Headers, 0) + 2
Data(k, j) = Cell.Offset(0, 3) ' Total
Dict.Add Key, j
j = j + 1
ReDim Preserve Data(1 To UBound(Headers, 2) + 2, 1 To j)
Else
n = Dict(Key)
k = Application.Match(Cell.Offset(0, 2), Headers, 0) + 2
Data(k, n) = Cell.Offset(0, 3) ' Total
End If
End If
Next Cell

' Output the the Data
Range("G2").Resize(j, k + 2).Value = Application.Transpose(Data)

End Sub

[YasserKhalil]

That's awesome and fascinating Mr. Leith
I liked it a lot specially because you put hints for me to get it properly
Thank you very very much for that masterpiece
Best Regards

[Leith Ross]

Hello Yasser,

You're welcome. Your posts almost always are challenging. If you have any questions about what the code is doing, let me know.

[YasserKhalil]

Thanks a lot. I followed the lines of code using F8 and got most of it. That's great Mr. Leith
Best and kind regards