VBA代码-在特定条件下复制和转置粘贴 [英] VBA Code - Copy and Transpose paste with specific conditions

问题描述

我已经编写了一个代码，该数据可以从Sheet3复制数据(连续)，然后将其粘贴到Sheet2的COLUMN c中.但是，我需要根据Sheet2列A1到A4000中的ID来中断复制和粘贴的行匹配D1到D4000列.

I have written a code which copies data (in a row) from Sheet3 and transpose paste into COLUMN c in Sheet2 However, I need to break the rows copied and pasted based on a condition that the ID in Sheet2 Column A1 TO A4000 matches Columns D1 TO D4000.

遍历Sheet3中的行，并通过将其填充到右侧(即转置)来粘贴它.

Looping through the rows in Sheet3 and pasting it by filling it to the right i.e. transpose.

例如:

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中，例如:

Should be Pasted into Sheet 2 As:

   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

我想遍历各行，而不必更改代码的源范围或目标范围.

I will like to loop through the rows without having to change the sourcerange or target range from the code.

推荐答案

这里是解决方案之一

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

这篇关于VBA代码-在特定条件下复制和转置粘贴的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！