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

【问题标题】：Excel VBA code for copy and transpose用于复制和转置的 Excel VBA 代码
【发布时间】：2017-01-29 22:09:45
【问题描述】：

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

行数据

最终结果

请帮助我。

【问题讨论】：

我不认为这是一个转置，对我来说看起来像是反规范化。
谢谢。这样的行数超过 10000 行。如何转换最终结果图像上的数据。
好的，我已经为你写了一些代码；）看我的回答。我也认为你应该编辑问题的标题。

标签： vba excel

【解决方案1】：

我希望你接受答案并投票试试这个

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

【讨论】：

Dictionary 使用的好例子。