VBA 代码 - 在特定条件下复制和转置粘贴

Question

我编写了一个代码，它从 Sheet3 复制数据（连续）并将粘贴转置到 Sheet2 中的 COLUMN c 但是，我需要根据 Sheet2 列 A1 中的 ID 到 A4000 的条件来中断复制和粘贴的行匹配 D1 到 D4000 列。

循环遍历 Sheet3 中的行并将其粘贴到右侧，即转置。

例如：

SHEET 3:
1 202  Anna
2 202  Mary
3 202  Gary
4 204 France
5 204  Greece
6 301 London
7 301 Alice
8 301 Mandy
9 406 HongKong
10 406 Osaka

应粘贴到工作表 2 中：

   A    B      C       D
1 202 Anna    Mary    Gary
2 204 France  Greece
3 301 London  Alice   Mandy

这是我当前的代码：

Dim Sourcerange  As Range
Dim Targetrange As Range


Set Sourcerange = Sheet3.Range("N3:N4105")
Set Targetrange = Sheet2.Range("C1:C4105")

Sourcerange.Copy
Targetrange.PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, _
            Transpose:=True

End Sub

我希望循环遍历行，而不必从代码中更改源范围或目标范围。

Answer 1

这里是解决方案之一

Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim CLa As Range, CLb As Range, x&, Names$, ID$, Key

x = Sheets("Sheet3").Cells(Rows.Count, "A").End(xlUp).Row
For Each CLa In Sheets("Sheet3").Range("A1:A" & x)
    If Not Dic.exists(CStr(CLa.Value)) Then
        ID = CLa.Value

        For Each CLb In Sheets("Sheet3").Range("A1:A" & x)
            If CLb.Value = ID Then

                If Names = "" Then
                    Names = CLb.Offset(, 1).Value
                Else
                    Names = Names & "," & CLb.Offset(, 1).Value
                End If

            End If
        Next CLb

    Dic.Add ID, Names
    End If
    ID = Empty: Names = Empty
Next CLa

x = 1
For Each Key In Dic
    Sheets("Sheet2").Cells(x, 1).Value = Key
    Sheets("Sheet2").Range(Cells(x, 2), Cells(x, 4)) = Split(Dic(Key), ",")
    x = x + 1
Next Key

Sheets("Sheet2").Cells.Replace "#N/A", Replacement:=""

End Sub

源表3

输出表2