基于匹配值的VBA Excel循环复制数据[关闭]答案

【问题标题】：VBA Excel Loop copy data based on matching values [closed]基于匹配值的VBA Excel循环复制数据[关闭]
【发布时间】：2018-04-05 10:27:03
【问题描述】：

我对 Excel VBA 还是很陌生，但我遇到了以下问题。我有一张表，我想像这样转换成一张新表：

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

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

【问题讨论】：

标签： excel loops vba

【解决方案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

【讨论】：