用于复制和转置的Excel VBA代码

Question

我需要一个VBA代码用于简单复制和（粘贴）转置行数据，结果如下所示

行数据

最终结果

请帮帮我。

Answer 1

我希望你接受回答和upvote 试试这个

Option Explicit

Sub Test()


    Dim rng As Excel.Range
    Set rng = Sheet1.Range("A1").CurrentRegion


    Dim dicMaster As Object
    Set dicMaster = VBA.CreateObject("Scripting.Dictionary")

    Dim lRowLoop As Long
    For lRowLoop = 1 To rng.Rows.Count
        Dim vLeft As Variant
        vLeft = rng.Cells(lRowLoop, 1)

        Dim vRight As Variant
        vRight = rng.Cells(lRowLoop, 2)

        Dim dicSub As Object
        If Not dicMaster.exists(vLeft) Then
            Set dicSub = VBA.CreateObject("Scripting.Dictionary")
            dicMaster.Add vLeft, dicSub
        End If
        Set dicSub = dicMaster.Item(vLeft)

        dicSub.Add dicSub.Count, vRight

    Next

    '* find the widest
    Dim lWidest As Long
    lWidest = 0
    Dim vKeyLoop As Variant
    For Each vKeyLoop In dicMaster.Keys

        Dim lCount As Long
        lCount = dicMaster(vKeyLoop).Count
        If lWidest < lCount Then lWidest = lCount
    Next
    '* so now dimension results

    ReDim vResults(1 To dicMaster.Count, 1 To lWidest + 1) As Variant

    Dim lRowIndex As Long
    For Each vKeyLoop In dicMaster.Keys
        lRowIndex = lRowIndex + 1

        vResults(lRowIndex, 1) = vKeyLoop
        Set dicSub = dicMaster.Item(vKeyLoop)

        Dim lColIndex As Long
        lColIndex = 2

        Dim vItemLoop As Variant
        For Each vItemLoop In dicSub.Items
            vResults(lRowIndex, lColIndex) = vItemLoop
            lColIndex = lColIndex + 1
        Next vItemLoop

    Next

    Sheet2.Cells(1, 1).Resize(dicMaster.Count, lWidest + 1) = vResults

End Sub