Get extra columns in output when transposing unique IDs - excel

Question

The following code is supposed to convert or transpose data from multiple rows to lesser rows by IDs
Here's sample of data in Sheet1
And this is the desired output
And here's the code I am trying but I got extra columns and not correct headers
Sub Test()
Dim a, tmp, i As Long, ii As Long, t As Long
a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
a(1, 2) = a(1, 2) & " 1"
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .Exists(a(i, 1)) Then
.Item(a(i, 1)) = Array(.Count + 2, 2)
tmp = a(i, 2)
a(.Count + 1, 1) = a(i, 1)
a(.Count + 1, 2) = a(i, 3)
a(.Count + 1, 3) = tmp
Else
t = .Item(a(i, 1))(1) + 2
If UBound(a, 2) < t Then
ReDim Preserve a(1 To UBound(a, 1), 1 To t)
a(1, t) = Replace(a(1, 2), "1", t - 1)
End If
a(.Item(a(i, 1))(0), t) = a(i, 2)
.Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t)
End If
Next i
t = .Count + 1
End With
With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2))
.CurrentRegion.Clear
.Value = a: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub
I adust the output a little by modifying this line
t = .Item(a(i, 1))(1) + 1

Answer 1

Using Collections
Sub Test2()
Dim ar, dict As Object, k
Dim t As Long, i As Long, r As Long
ar = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ar)
k = ar(i, 1)
If Not dict.exists(k) Then
dict.Add k, New Collection
dict(k).Add ar(i, 3) ' date
End If
dict(k).Add ar(i, 2) ' Item
If dict(k).Count > t Then t = dict(k).Count
Next
ReDim ar(1 To dict.Count + 1, 1 To t + 1)
ar(1, 1) = "ID"
ar(1, 2) = "Date"
For i = 2 To t
ar(1, i + 1) = "MyH " & i - 1
Next
r = 2
For Each k In dict
ar(r, 1) = k
For i = 1 To dict(k).Count
ar(r, i + 1) = dict(k).Item(i)
Next
r = r + 1
Next
With Sheets("Sheet2").Cells(1).Resize(UBound(ar), UBound(ar, 2))
.CurrentRegion.Clear
.Value = ar: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub

Answer 2

I have played around the code and could adust the output but I welcome any other solutions
Sub Test()
Dim a, tmp, i As Long, ii As Long, t As Long
a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
a(1, 3) = a(1, 2) & " 1"
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .Exists(a(i, 1)) Then
.Item(a(i, 1)) = Array(.Count + 2, 3)
tmp = a(i, 2)
a(.Count + 1, 1) = a(i, 1)
a(.Count + 1, 2) = a(i, 3)
a(.Count + 1, 3) = tmp
Else
t = .Item(a(i, 1))(1) + 1
If UBound(a, 2) < t Then
ReDim Preserve a(1 To UBound(a, 1), 1 To t)
a(1, t) = Replace(a(1, 3), "1", t - 2)
End If
a(.Item(a(i, 1))(0), t) = a(i, 2)
.Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t)
End If
Next i
t = .Count + 1
End With
a(1, 2) = "Date"
With Sheets("Sheet2").Cells(1).Resize(t, UBound(a, 2))
.CurrentRegion.Clear
.Value = a: .Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
.Parent.Select
End With
End Sub