VBA Excel循环复制数据基于匹配值

Question

我对Excel VBA很陌生，我坚持以下问题。 我有一张桌子，我希望转换成一个像这样的新桌子：

A列中的每个唯一值可以在B列中具有多个不同的单元格（单元格的数量不同）。我希望只有当两个表的A列中的值匹配时才继续从B列复制循环，但如果它们不匹配则转到下一行并执行相同操作。

不确定这是否清楚，但希望所包含的图片有所帮助。非常感谢任何帮助，谢谢！

Answer 1

这份工作。使用工作表名称

更新它

Sub transpose()
    Dim tmp As Variant
    Dim Dict As Object
    Dim rng As Range
    Dim c, Key
    Dim i As Long

    ' Change to your worksheet
    With Sheet4
        Set rng = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))

        Set Dict = CreateObject("Scripting.Dictionary")

        For Each c In rng
            ReDim tmp(1 To 1)
            If Not Dict.exists(c.Value2) Then Dict.Add Key:=c.Value2, Item:=tmp
            tmp = Dict(c.Value2)

            tmp(UBound(tmp)) = c.Offset(0, 1).Value2
            ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
            Dict(c.Value2) = tmp
        Next c

        ' Set to your destination
        With .Cells(1, 5)
            Range(.Offset(1, 0), .Offset(Dict.Count, 0)).Value2 = Application.Transpose(Dict.keys)
            For Each Key In Dict.keys
                i = i + 1
                tmp = Dict(Key)
                Range(.Offset(i, 1), .Offset(i, UBound(Dict(Key)))).Value2 = Dict(Key)
            Next Key
        End With
    End With
End Sub