Код VBA - скопировать и переместить пасту с определенными условиями

Question

Я написал код, который копирует данные (в строке) из Sheet3 и транспонирует пасту в COLUMN c в Sheet2. Однако мне нужно разбить строки, скопированные и вставленные на основе условие, что идентификатор в Sheet2 Column A1 TO A4000 соответствует столбцам D1 TO 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 

Источник Sheet3

Выход sheet2