具有特定条件的VBA代码复制和转置粘贴

相关文章推荐

任性的高山 · 【已解决】RuntimeError: ...· 6 月前 ·

坏坏的莴苣 · 济宁市人民政府历史名人名人印迹· 1 年前 ·

光明磊落的墨镜 · 志愿者马忠义：勇做兵团家园的守护者和建设者_ ...· 1 年前 ·

有胆有识的鼠标垫 · 四川南充破获特大电信网络诈骗案 ...· 2 年前 ·

傲视众生的铁板烧 · 邪凤求凰 - 🌈️包子漫畫· 2 年前 ·

腾讯云

备案控制台

开发者社区

TVP

文章/答案/技术大牛

写文章

具有特定条件的VBA代码复制和转置粘贴

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

   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

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
                    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), ",")

推荐文章

任性的高山 · 【已解决】RuntimeError: CUDA error: device-side assert triggeredCUDA kernel errors might be asynchronous-

6 月前

坏坏的莴苣 · 济宁市人民政府历史名人名人印迹

1 年前

光明磊落的墨镜 · 志愿者马忠义：勇做兵团家园的守护者和建设者_大学生志愿服务西部计划_中国青年网

1 年前

有胆有识的鼠标垫 · 四川南充破获特大电信网络诈骗案 842名缅北回流人员归案_中国网

2 年前

傲视众生的铁板烧 · 邪凤求凰 - 🌈️包子漫畫

2 年前

具有特定条件的VBA代码复制和转置粘贴

1 个回答