Get extra columns in output when transposing unique IDs-CodePudding

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

CodePudding user response：

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

CodePudding user response：

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