时间戳

首页 > 解决方案 > 转置唯一 ID 时在输出中获取额外的列

excel - 转置唯一 ID 时在输出中获取额外的列

问题描述

以下代码应该通过 ID 将数据从多行转换或转置为较少的行这是 Sheet1 中的数据示例 在此处输入图像描述

这是所需的输出 在此处输入图像描述

这是我正在尝试的代码，但我得到了额外的列而不是正确的标题

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

我通过修改这一行来稍微调整输出

t = .Item(a(i, 1))(1) + 1

标签： excelvba

解决方案

使用集合

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

推荐阅读