VBA转置唯一ID对应数据时输出出现额外列问题求解

问题原因 #

原代码的列偏移逻辑存在两处核心错误：

• 新增同ID属性列时每次多跳了1个列位，导致产生多余空列
• 表头生成时的序号计算和列位不匹配，导致表头内容错位

修正后完整代码 #

Sub Test()
    Dim a, tmp, i As Long, t As Long, maxCol As Long
    ' 读取Sheet1前三列数据
    a = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
    ' 初始化表头：第2、3列对应第一个属性+值
    a(1, 2) = a(1, 2) & " 1"
    a(1, 3) = a(1, 3) & " 1"
    maxCol = 3
    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)
                a(.Count + 1, 1) = a(i, 1)
                a(.Count + 1, 2) = a(i, 2)
                a(.Count + 1, 3) = a(i, 3)
            Else
                ' 每次新增2列：对应新的属性+值对
                t = .Item(a(i, 1))(1) + 1
                ' 数组动态扩容
                If maxCol < t + 1 Then
                    ReDim Preserve a(1 To UBound(a, 1), 1 To t + 1)
                    ' 生成对应表头
                    seq = (t + 1) / 2
                    a(1, t) = Replace(a(1, 2), "1", seq)
                    a(1, t + 1) = Replace(a(1, 3), "1", seq)
                    maxCol = t + 1
                End If
                ' 写入当前属性和值
                a(.Item(a(i, 1))(0), t) = a(i, 2)
                a(.Item(a(i, 1))(0), t + 1) = a(i, 3)
                ' 更新字典存储的最大列号
                .Item(a(i, 1)) = Array(.Item(a(i, 1))(0), t + 1)
            End If
        Next i
        t = .Count + 1
    End With
    ' 输出结果到Sheet2
    With Sheets("Sheet2").Cells(1).Resize(t, maxCol)
        .CurrentRegion.Clear
        .Value = a: .Borders.Weight = 2
        .HorizontalAlignment = xlCenter
        .Columns.AutoFit
        .Parent.Select
    End With
End Sub

核心修改说明 #

• 调整了列偏移计算规则，新增属性时的列位移和序号计算完全匹配，不会产生多余空白列
• 修正了表头生成逻辑，保证表头名称和下方数据列的对应关系完全正确
• 新增maxCol变量跟踪实际使用的最大列数，避免输出冗余空白列

内容的提问来源于stack exchange，提问作者YasserKhalil