用于复制和转置的Excel VBA代码 [英] Excel VBA code for copy and transpose

问题描述

我需要一个VBA代码来进行简单的复制和(粘贴)转置行数据，结果如下所示

I need a VBA code for a simple copy and (paste) transpose row data and results looks like below

请帮助我.

推荐答案

我希望您接受回答并支持试试这个

I hope you accept answer and upvote Try this

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

这篇关于用于复制和转置的Excel VBA代码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！