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:

Answer 1

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

Answer 2

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

Answer 3

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)<>""))

Answer 4

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