excel - 在多列上将垂直转换为水平

Question

我有一个将列从垂直状态转换为水平状态的代码(每组在一行中)
这是一些虚拟数据

Groups  Amount  Notes   Name
A   10  N1  GroupA
A   20  N2  GroupA
A   30  N3  GroupA
B   40  N4  GroupB
B   50  N5  GroupB
B   60  N6  GroupB
B   70  N7  GroupB
C   80  N8  GroupC
D   90  N9  GroupD
D   100 N10 GroupD

这是仅处理第二列的代码

Sub Test()
    Dim v, a, i As Long
    v = Cells(1).CurrentRegion
    ReDim b(UBound(v) + 1)
    With CreateObject("Scripting.Dictionary")
        For i = 2 To UBound(v)
            a = .Item(v(i, 1))
            If IsEmpty(a) Then a = b
            a(0) = v(i, 1)
            a(UBound(a)) = a(UBound(a)) + 1
            a(a(UBound(a))) = v(i, 2)
            .Item(v(i, 1)) = a
        Next i
        Range("G2").Resize(.Count, UBound(a) - 1) = Application.Index(.Items, 0)
    End With
End Sub

该代码适用于第二列，但我也需要以相同的想法处理第三列。至于第四列将只有一次(在输出中将在一列中)
这是预期的输出

Answer 1

您的问题的解决方案比最初看起来要复杂一些。但是感谢您使用字典而不是尝试通过数组来做所有事情。
下面的代码使用了一个字典，它的键是 Groups 列中的值。与这些键关联的 Item 是一个 Arraylist。反过来，Arraylist 由 Arraylists 填充，其中包含与 Group Column 中的 Key 对应的每一行的 Amount、Note 和 Nname 值。使用 Arraylist 是因为我们可以轻松地从 An Arraylist 中删除项目。
请注意，Scripting.Dictionaries 和 ArrayLists 的 Item 方法是默认方法，因此我没有在代码中明确调用 Item 方法。如果默认方法不是项目，那么我会特别说明默认方法。
下面的代码比你原来的帖子要长很多，但我希望你能看到事情是如何被分成逻辑任务的。
您还将看到我大量使用垂直间距来将 codee withing 方法分解为“段落”。这是个人喜好。

Public Sub Test2()

    Dim myD As Scripting.Dictionary
    Set myD = GetCurrentRegionAsDictionary(Cells(1).CurrentRegion)
    
    Dim myArray As Variant
    myArray = GetPopulatedOutputArray(myD)

    Dim Destination As Range
    Set Destination = Range("A20")
    Destination.Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray

    
End Sub
 
'@Description("Returns an Array in the desired output format from the contents of the Scripting.Dictionary created from the CurrentRegion")
Public Function GetPopulatedOutputArray(ByRef ipD As Scripting.Dictionary) As Variant

    Dim myAmountSpan As Long
    myAmountSpan = MaxSubArrayListSize(ipD)
    
    Dim myArray As Variant
    ReDim myArray(1 To ipD.Count, 1 To 2 + myAmountSpan * 2)
    
    Dim myHeaderText As Variant
    myHeaderText = GetHeaderTextArray(ipD, myAmountSpan)
    
    Dim myIndex As Long
    For myIndex = 0 To UBound(myHeaderText)
    
        myArray(1, myIndex + 1) = myHeaderText(myIndex)
    Next
    
    Dim myRow As Long
    myRow = 2
    Dim myKey As Variant
    For Each myKey In ipD
    
        myArray(myRow, 1) = myKey
    
        Dim myCol As Long
        myCol = 2
        Dim myList As Variant
        For Each myList In ipD(myKey)
        
            myArray(myRow, myCol) = myList(0)
            myArray(myRow, myCol + myAmountSpan) = myList(1)
            
            If VBA.IsEmpty(myArray(myRow, UBound(myArray, 2))) Then
            
                myArray(myRow, UBound(myArray, 2)) = myList(2)
            
            End If
            
            myCol = myCol + 1
            
        Next

        myRow = myRow + 1
        
    Next
    
    GetPopulatedOutputArray = myArray
   
End Function

'@Description("Returns an array contining the appropriately formatted header text")
Public Function GetHeaderTextArray(ByRef ipD As Scripting.Dictionary, ByVal ipAmountSpan As Long) As Variant

    ' The Scripting.Dictionary does not maintain order of addition
    ' so we need to search for a key longer than one character
    
    Dim myFoundKey As String
    Dim myHeaderList As ArrayList
    
    Dim myKey As Variant
    For Each myKey In ipD
    
        If Len(myKey) > 2 Then
        
            myFoundKey = myKey
            Set myHeaderList = ipD(myKey)(0)
            Exit For
            
        End If
        
    Next
    
    Dim myT As String
    myT = myFoundKey & ","
    
    Dim myIndex As Long
    For myIndex = 1 To ipAmountSpan
        myT = myT & myHeaderList(0) & CStr(myIndex) & ","
    Next
    
    For myIndex = 1 To ipAmountSpan
        myT = myT & myHeaderList(1) & CStr(myIndex) & ","
    Next
    
    myT = myT & myHeaderList(2)
    
    ' removeove the header text as it is no longer needed
    ipD.Remove myFoundKey
    GetHeaderTextArray = Split(myT, ",")
    
End Function

'@Description("Returns a Dictionary of arraylists using column 1 of the current region as the key
Public Function GetCurrentRegionAsDictionary(ByRef ipRange As Excel.Range) As Scripting.Dictionary

    Dim myArray As Variant
    myArray = ipRange.Value
    
    Dim myD As Scripting.Dictionary
    Set myD = New Scripting.Dictionary
    
    Dim myRow As Long
    For myRow = LBound(myArray, 1) To UBound(myArray, 1)
    
        Dim myList As ArrayList
        Set myList = GetRowAsList(myArray, myRow)
        
        Dim myKey As Variant
        Assign myKey, myList(0)
        myList.RemoveAt 0
        If Not myD.Exists(myKey) Then
        
            myD.Add myKey, New ArrayList
            
        End If
        
        ' Add an arraylist to the arraylist specified by Key
        myD.Item(myKey).Add myList
        
    Next
    
    Set GetCurrentRegionAsDictionary = myD
    
End Function

'@Description("Get the size of largest subArrayList")
Public Function MaxSubArrayListSize(ByRef ipD As Scripting.Dictionary) As Long

    Dim myMax As Long
    myMax = 0
    Dim myKey As Variant
    For Each myKey In ipD
    
        If ipD(myKey).Count > myMax Then
        
            myMax = ipD(myKey).Count
            
        
        End If
        
    Next
    
    MaxSubArrayListSize = myMax
    
End Function


'@Description("Returns a row of an Array as an ArrayList")
Public Function GetRowAsList(ByRef ipArray As Variant, ByVal ipRow As Long) As ArrayList

    Dim myList As ArrayList
    Set myList = New ArrayList
    
    Dim myIndex As Long
    For myIndex = LBound(ipArray, 2) To UBound(ipArray, 2)
    
        myList.Add ipArray(ipRow, myIndex)
        
        
    Next
    
    Set GetRowAsList = myList
    
End Function


Public Sub Assign(ByRef ipTo As Variant, ByRef ipFrom As Variant)

    If VBA.IsObject(ipFrom) Then
    
        Set ipTo = ipFrom
        
    Else
    
        ipTo = ipFrom
        
    End If
    
End Sub