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