Convert vertical to horizontal on multiple columns

Question

I have a code that converts a column from vertical state to horizontal (each group to be in one row) Here's some dummy data

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

Here's the code that deals with the second column only

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

The code works fine for the second column, but I need to deal with the third column too with the same idea. And as for the fourth column will be just once (in the output would be in one column)

Here's the expected output

Answer 1

I did it a little differently:

Sub ColsToRows()

Dim dict As Dictionary
Dim inner As Dictionary
Dim arr() As Variant
Dim arrNotExpand() As Variant

'add headers of columns you don't want to have expanded to array
arrNotExpand = Array("Name")

Dim myRange As Range
'set start of range you want to be converted; vals in first column will be used for keys in main dict
Set myRange = Range("A1").CurrentRegion

Dim Destination As Range
'set start destination range
Set Destination = Range("G1")

'creating main dict
Set dict = New Dictionary

'looping through all cells in first column (ex header)
For x = 2 To myRange.Rows.Count

    'define key
    dictKey = Cells(x, 1).Value

    'check if key exists
    If dict.Exists(dictKey) Then
    
        'if exists, get innerKey, add val from each col to its inner dict
        For y = 2 To myRange.Columns.Count

            innerKey = Cells(1, y).Value
            newVal = Cells(x, y).Value

            'getting array from key, adding val to it, and reassigning updated array
            arr = dict(dictKey)(innerKey)
            ReDim Preserve arr(UBound(arr) + 1)
            arr(UBound(arr)) = newVal

            dict(dictKey)(innerKey) = arr
        
        Next y
    
    Else
        
        'key does not exist, create new inner dict
        Set inner = New Dictionary
        
        'add inner dict for each col, and assign first vals
        For y = 2 To myRange.Columns.Count
            
            innerKey = Cells(1, y).Value
            newVal = Cells(x, y).Value
            
            arr = Array(newVal)
            
            inner.Add innerKey, arr
        
        Next y
        
        'add inner dict to main dict
        dict.Add dictKey, inner
    
    End If

Next x

'establish maxCols, i.e. the max length of any array for inner
maxCols = 1

'since we're retrieving the expanded version of arr for each inner, we can just check the first to get the maxCols val
For Each dictKey In dict.Keys

    'checking lengthArray
    lengthArray = UBound(dict(dictKey)(dict(dictKey).Keys()(1))) + 1

    'if it is larger than prev stored val, use new length
    If lengthArray > maxCols Then
    
    maxCols = lengthArray
    
    End If

Next dictKey

'convert dict to Destination

'header for keys main dict
Destination = myRange.Cells(1, 1)

'keep track of offset rows
countRow = 0

For Each dictKey In dict.Keys

    'keep trach of offset cols
    countCol = 0

    For Each innerKey In dict(dictKey)
    
        'if so, add the dictKey
        If countCol = 0 Then
        
            Destination.Offset(1 + countRow, 0) = dictKey
        
        End If

        'if innerKey not in arrNotExpand, we want use full array
        If IsError(Application.Match(innerKey, arrNotExpand, 0)) Then
            
            'if we are looking at the first key, also add the headers for each inner dict key
            If countRow = 0 Then
        
                For col = 1 To maxCols
                    
                    'add increment for headers, e.g. "Amount1", "Amount2" etc. (replace necessary for getting rid of whitespace)
                    Destination.Offset(countRow, 1 + countCol + col - 1) = Replace(innerKey + Str(col), " ", "")
                
                Next col
            
            End If
        
            'get length of arr for specific inner dict
            lengthArray = UBound(dict(dictKey)(innerKey)) + 1
    
            'use here for resizing and fill with array
            Destination.Offset(1 + countRow, 1 + countCol).Resize(1, lengthArray) = dict(dictKey)(innerKey)
            
            'adjust offset cols
            countCol = countCol + maxCols
        
        Else
        
            'only True if the first innerKey is in arrNotExpand
            If countRow = 0 Then
        
                Destination.Offset(countRow, 1 + countCol) = innerKey
            
            End If
            
            'no expansion, so use only first val from array
            Destination.Offset(1 + countRow, 1 + countCol) = dict(dictKey)(innerKey)(0)
            
            'adjust offset col just by one
            countCol = countCol + 1
            
        End If
        
    Next innerKey
    
    'adjust offset row for next dict key
    countRow = countRow + 1
    
Next dictKey

End Sub

Make sure to enter the correct references for Set myRange = Range("A1").CurrentRegion and Set Destination = Range("F1"). Add the headers for columns that you don't want to expand to this array : arrNotExpand = Array("Name"). As is, you'll get the expected output. Let's say you add "Amount" as well, so: arrNotExpand = Array("Amount", "Name"), then you'll get this:

If you add more columns to the range, this works. Just make sure that all your headers are unique (else you'll run into an error with assigning new dict.keys). Let me know if anything is unclear, or if you find a bug.

Answer 2

The solution to your problem is a little more complicated than it first seems. But kudos to you for using a Dictionary rather than trying to do everything via arrays.

The code below uses a Dictionary whose keys are the values in the Groups column. The Item associated with these keys is an Arraylist. In turn, the Arraylist is populated with Arraylists comprising the Amount,Note and Nname values for each row corresponding to the Key in the Group Column. The Arraylist is used because we can easily delete items from An Arraylist.

Note that the Item method of Scripting.Dictionaries and ArrayLists is the default method, and for this reason I don't explicity invoke the Item method in the code. If the default method were something other than Item, then I would have specifically stated the default method.

The code below is a good deal longer than in your original post, but I will hope you will see how things have been split up into logical tasks.

You will also see that I use vertical spacing a lot to break codee withing methods into 'paragraphs'. This is a personal preference.

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