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

我需要一个简单的复制和（粘贴）转置行数据的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