Transpose multiple columns to multiple rows with VBA

Question

This is the kind of transformation is what I am trying to perform.
For illustration I made this as table. Basically the first three columns should repeat for however many colors are available.

I searched for similar questions but could not find when I want multiple columns to repeat.

I found this code online

Sub createData()
    Dim dSht As Worksheet
    Dim sSht As Worksheet
    Dim colCount As Long
    Dim endRow As Long
    Dim endRow2 As Long
     
    Set dSht = Sheets("Sheet1") 'Where the data sits
    Set sSht = Sheets("Sheet2") 'Where the transposed data goes
     
    sSht.Range("A2:C60000").ClearContents
    colCount = dSht.Range("A1").End(xlToRight).Column
     
     '// loops through all the columns extracting data where "Thank" isn't blank
    For i = 2 To colCount Step 2
        endRow = dSht.Cells(1, i).End(xlDown).Row
        For j = 2 To endRow
            If dSht.Cells(j, i) <> "" Then
                endRow2 = sSht.Range("A50000").End(xlUp).Row + 1
                sSht.Range("A" & endRow2) = dSht.Range("A" & j)
                sSht.Range("B" & endRow2) = dSht.Cells(j, i)
                sSht.Range("C" & endRow2) = dSht.Cells(j, i).Offset(0, 1)
            End If
        Next j
    Next i
End Sub

I tried changing step 2 to 1 and j to start from 4.

Another example with two varied sets:

You shouldn't be working with worksheet ranges within [ListObject](https://msdn.microsoft.com/en-us/library/office/aa174247.aspx) tables. Work with the [.DataBodyRange property](https://msdn.microsoft.com/en-us/library/microsoft.office.tools.excel.listobject.databodyrange.aspx) instead. — , Apr 01 '16 at 21:25
@Jeeped: Damn this question is closed. :D I was typing an answer which used a completely different approach using Arrays — Siddharth Rout, Apr 01 '16 at 21:45
@Jeeped: The link that you gave doesn't cater to blank color cells — Siddharth Rout, Apr 01 '16 at 21:48
@Jeeped: If you still feel that this question should be closed as a duplicate, you may close it :) — Siddharth Rout, Apr 01 '16 at 21:58
OP - please select an answer and click the check mark next to it so this question can be marked as closed, and we can then use it as "duplicate" for other similar questions. — Tim Williams, Apr 04 '16 at 20:11

Tim Williams · Accepted Answer · 2020-11-02T19:44:40.463

Here's a generic "unpivot" approach (all "fixed" columns must appear on the left of the columns to be unpivoted)

Test sub:

Sub Tester()
    
    Dim p
    
    'get the unpivoted data as a 2-D array
    p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _
                  3, False, False)
                
    With Sheets("Sheet1").Range("H1")
        .CurrentRegion.ClearContents
        .Resize(UBound(p, 1), UBound(p, 2)).Value = p 'populate array to sheet
    End With

    'EDIT: alternative (slower) method to populate the sheet
    '      from the pivoted dataset.  Might need to use this
    '      if you have a large amount of data
    'Dim r As Long, c As Long
    'For r = 1 To Ubound(p, 1)
    'For c = 1 To Ubound(p, 2)
    '    Sheets("Sheet2").Cells(r, c).Value = p(r, c)
    'Next c
    'Next r

End Sub

UnPivot function - should not need any modifications:

Function UnPivotData(rngSrc As Range, fixedCols As Long, _
                   Optional AddCategoryColumn As Boolean = True, _
                   Optional IncludeBlanks As Boolean = True)

    Dim nR As Long, nC As Long, data, dOut()
    Dim r As Long, c As Long, rOut As Long, cOut As Long, cat As Long
    Dim outRows As Long, outCols As Long
    
    data = rngSrc.Value 'get the whole table as a 2-D array
    nR = UBound(data, 1) 'how many rows
    nC = UBound(data, 2) 'how many cols

    'calculate the size of the final unpivoted table
    outRows = nR * (nC - fixedCols)
    outCols = fixedCols + IIf(AddCategoryColumn, 2, 1)
    
    'resize the output array
    ReDim dOut(1 To outRows, 1 To outCols)
               
    'populate the header row
    For c = 1 To fixedCols
        dOut(1, c) = data(1, c)
    Next c
    If AddCategoryColumn Then
        dOut(1, fixedCols + 1) = "Category"
        dOut(1, fixedCols + 2) = "Value"
    Else
        dOut(1, fixedCols + 1) = "Value"
    End If
    
    'populate the data
    rOut = 1
    For r = 2 To nR
        For cat = fixedCols + 1 To nC
            
            If IncludeBlanks Or Len(data(r, cat)) > 0 Then
                rOut = rOut + 1
                'Fixed columns...
                For c = 1 To fixedCols
                    dOut(rOut, c) = data(r, c)
                Next c
                'populate unpivoted values
                If AddCategoryColumn Then
                    dOut(rOut, fixedCols + 1) = data(1, cat)
                    dOut(rOut, fixedCols + 2) = data(r, cat)
                Else
                    dOut(rOut, fixedCols + 1) = data(r, cat)
                End If
            End If

        Next cat
    Next r
    
    UnPivotData = dOut
End Function

Change the 3 to 7 and edit the destination range to where you want the data to go — Tim Williams, Apr 04 '16 at 14:47
Answered for :If I have 7 fixed columns and 8 max values(colors) I have to change 3 to 7 in the sub in the function for fixedcols right and change H1 to where there are no values in :- With Sheets("Sheet1").Range**("H1")** — viji, Apr 04 '16 at 15:09
If I have one more set of varying columns like for this example if there is size which has varying number of alternatives like Color. So creating a column which says type which either mentions color or size. The fixed column would repeat for this as well. eg attached in original question — viji, Apr 15 '16 at 19:17
the code works to get the value column but how can I create a column which says type as either color or size accordingly. Help is appreciated. Original columns could be just Color or Size does not matter — viji, Apr 15 '16 at 20:00
to answer my own question, if I change here ' p = UnPivotData(Sheets("Sheet1").Range("A1").CurrentRegion, _ 3, False, False)' the first false to true then it gives category as either color or size accordingly — viji, Apr 15 '16 at 20:44
I have large text in one of the columns so I am getting out of memory error at `.Resize(UBound(p, 1), UBound(p, 2)).Value = p` . Is there any way to free up the space? — viji, May 04 '16 at 17:28
It would be much slower but you could loop over the array and write the data cell-by-cell — Tim Williams, May 04 '16 at 17:36
I tried using this code to finally populate 2d array : `Dim i, j For i = LBound(p, 1) To UBound(p, 1) For j = LBound(p, 2) To UBound(p, 2) Cells(r, c) = p(i, j) c = c + 1 Next j c = 2 r = r + 1 Next i ` But i was not sure what should be the rows and column(r,c) because the number of rows would change depending on the blanks and columns are dynamic depending on if category column is required?Is my approach right? — viji, May 06 '16 at 18:01
When i try says sub or function not defined, is that because i have to add the function as well. — shaneo, Apr 04 '21 at 12:03

score 4 · Answer 2 · edited May 23 '17 at 11:53

Here is one way (fastest?) using arrays. This approach is better that the linked question as it doesn't read and write to/from range objects in a loop. I have commented the code so you shouldn't have a problem understanding it.

Option Explicit

Sub Sample()
    Dim wsThis As Worksheet, wsThat As Worksheet
    Dim ThisAr As Variant, ThatAr As Variant
    Dim Lrow As Long, Col As Long
    Dim i As Long, k As Long

    Set wsThis = Sheet1: Set wsThat = Sheet2

    With wsThis
        '~~> Find Last Row in Col A
        Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
        '~~> Find total value in D,E,F so that we can define output array
        Col = Application.WorksheetFunction.CountA(.Range("D2:F" & Lrow))

        '~~> Store the values from the range in an array
        ThisAr = .Range("A2:F" & Lrow).Value

        '~~> Define your new array
        ReDim ThatAr(1 To Col, 1 To 4)

        '~~> Loop through the array and store values in new array
        For i = LBound(ThisAr) To UBound(ThisAr)
            k = k + 1

            ThatAr(k, 1) = ThisAr(i, 1)
            ThatAr(k, 2) = ThisAr(i, 2)
            ThatAr(k, 3) = ThisAr(i, 3)

            '~~> Check for Color 1
            If ThisAr(i, 4) <> "" Then ThatAr(k, 4) = ThisAr(i, 4)

            '~~> Check for Color 2
            If ThisAr(i, 5) <> "" Then
                k = k + 1
                ThatAr(k, 1) = ThisAr(i, 1)
                ThatAr(k, 2) = ThisAr(i, 2)
                ThatAr(k, 3) = ThisAr(i, 3)
                ThatAr(k, 4) = ThisAr(i, 5)
            End If

            '~~> Check for Color 3
            If ThisAr(i, 6) <> "" Then
                k = k + 1
                ThatAr(k, 1) = ThisAr(i, 1)
                ThatAr(k, 2) = ThisAr(i, 2)
                ThatAr(k, 3) = ThisAr(i, 3)
                ThatAr(k, 4) = ThisAr(i, 6)
            End If
        Next i
    End With

    '~~> Create headers in Sheet2
    Sheet2.Range("A1:D1").Value = Sheet1.Range("A1:D1").Value

    '~~> Output the array
    wsThat.Range("A2").Resize(Col, 4).Value = ThatAr
End Sub

SHEET1

SHEET2

If I have 7 fixed column and 6 colors, do I have to repeat for each color? Is there a way to take input from the user as to how many colors they may have in the table and depending on that run the code? — viji, Apr 04 '16 at 14:20

score 0 · Answer 3 · answered Feb 19 '21 at 14:16

The addition of the LET function allows for this non-VBA solution.

=LET(data,B3:F6,
     dataRows,ROWS(data),
     dataCols,COLUMNS(data),
     rowHeaders,OFFSET(data,0,-1,dataRows,1),
     colHeaders,OFFSET(data,-1,0,1,dataCols),
     dataIndex,SEQUENCE(dataRows*dataCols),
     rowIndex,MOD(dataIndex-1,dataRows)+1,
     colIndex,INT((dataIndex-1)/dataRows)+1,
     FILTER(CHOOSE({1,2,3}, INDEX(rowHeaders,rowIndex), INDEX(colHeaders,colIndex), INDEX(data,rowIndex,colIndex)), index(data,rowIndex,colIndex)<>""))

score 0 · Answer 4 · answered Jun 05 '22 at 22:16

Below is a custom function I wrote for such things (demo video I posted on YouTube). A few differences from other answers:

The custom function allows for more than one axis in columns. As shown below, the column axis has Currency and Time.
Row axis does not need to be directly next to the data range.
One can specify the entire row as the column axis or the entire column to specify the row axis. See formula used as example below.

So with this data set:

And entering this as the formula:

=unPivotData(D4:G7,2:3,B:C)

an output of this:

Function unPivotData(theDataRange As Range, theColumnRange As Range, theRowRange As Range, _
   Optional skipZerosAsTrue As Boolean, Optional includeBlanksAsTrue As Boolean)

'Set effecient range
Dim cleanedDataRange As Range
    Set cleanedDataRange = Intersect(theDataRange, theDataRange.Worksheet.UsedRange)
   
'tests Data ranges
   With cleanedDataRange

    'Use intersect address to account for users selecting full row or column
   If .EntireColumn.Address <> Intersect(.EntireColumn, theColumnRange).EntireColumn.Address Then
      unPivotData = "datarange missing Column Ranges"

   ElseIf .EntireRow.Address <> Intersect(.EntireRow, theRowRange).EntireRow.Address Then
      unPivotData = "datarange missing row Ranges"

   ElseIf Not Intersect(cleanedDataRange, theColumnRange) Is Nothing Then
      unPivotData = "datarange may not intersect column range.  " & Intersect(cleanedDataRange, theColumnRange).Address
      
   ElseIf Not Intersect(cleanedDataRange, theRowRange) Is Nothing Then
      unPivotData = "datarange may not intersect row range.  " & Intersect(cleanedDataRange, theRowRange).Address
   
   End If

   'exits if errors were found
   If Len(unPivotData) > 0 Then Exit Function
   
   Dim dimCount As Long
      dimCount = theColumnRange.Rows.Count + theRowRange.Columns.Count
   
   Dim aCell As Range, i As Long, g As Long
   ReDim newdata(dimCount, i)
   End With
   'loops through data ranges
   For Each aCell In cleanedDataRange.Cells
      With aCell
      If .Value2 = "" And Not (includeBlanksAsTrue) Then
         'skip
      ElseIf .Value2 = 0 And skipZerosAsTrue Then
         'skip
      Else
         ReDim Preserve newdata(dimCount, i)
         g = 0
         
      'gets DimensionMembers members
         For Each gcell In Union(Intersect(.EntireColumn, theColumnRange), _
            Intersect(.EntireRow, theRowRange)).Cells
               
            newdata(g, i) = IIf(gcell.Value2 = "", "", gcell.Value)
            g = g + 1
         Next gcell
      
         newdata(g, i) = IIf(.Value2 = "", "", .Value)
         i = i + 1
      End If
      End With
   Next aCell
   
   unPivotData = WorksheetFunction.Transpose(newdata)

End Function

Transpose multiple columns to multiple rows with VBA

4 Answers4

Linked

Related