Unpivoting two categories of columns using VBA

Question

I have code that unpivots columns with the category of Line1, Line2, Line3, Line4 into one Column called Lines.

I want to unpivot two categories at the same time: Line1, Line2, Line3, Line4 & Color1, Color2, Color3, Color4 -----> Unit Name & Color (each with their own columns).

I have attached two table pictures. The second pic is how I want to look.

The code unpivots Columns H-K, but I also want to unpivot Columns N-Q.

I tried using the table function on here but it doesn't work very well for me due to the size of my data.

Option Explicit

Sub TransformData()

    ' 1. Define constants (the arrays obviously aren't constants).

    ' s - source (read from)
    ' sd - source data (no headers)
    ' d - destination (write to)
    ' r - row
    ' c - column
    ' u - unpivot (columns)
    ' v - value (columns)
    
    ' Source
    Const sName As String = "Sheet1"
    ' These columns will be unpivoted...
    Dim suCols() As Variant: suCols = VBA.Array(8, 9, 10, 11)
    ' ... while these columns will be just copied except for the 0 column...
    Dim svCols() As Variant: svCols = VBA.Array(12, 4, 0, 5, 6, 2, 3, 13, 14, 15, 16, 17)
    ' which is a 'place holder' for the pivot column.
    ' The 'svCols' array 'tells' that column 12 will be written to column 1,
    ' column 4 will be written to column 2, the unpivot columns will be written
    ' to column 3, ... etc.
    
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A1"
    Const duTitle As String = "Unit Name"

    ' 2. Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' 3. Reference the source worksheet ('sws'), the source range ('srg')
    ' and the source data range ('sdrg'). Also, write the number of rows
    ' of each of the ranges to variables ('srCount', 'sdrCount')
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' has headers
    Dim srCount As Long: srCount = srg.Rows.Count ' incl. headers
    Dim sdrCount As Long: sdrCount = srCount - 1 ' excl. headers
    Dim sdrg As Range: Set sdrg = srg.Resize(sdrCount).Offset(1) ' no headers
    
    ' 4. The Number of Destination Rows and Columns
    
    ' Determine the number of destination rows ('drCount').
    
    Dim suUpper As Long: suUpper = UBound(suCols) ' represents the highest index number with suCols
    Dim drCount As Long: drCount = 1 ' headers
    
    Dim su As Long
    
    For su = 0 To suUpper
        drCount = drCount + sdrCount _
            - Application.CountBlank(sdrg.Columns(suCols(su)))
    Next su
    
    ' Determine the number of destination columns ('dcCount').
    Dim svUpper As Long: svUpper = UBound(svCols)
    Dim dcCount As Long: dcCount = svUpper + 1
    
    ' 5. The 2D One-Based Arrays
    
    ' Write the values from the source range to an array ('sData').
    Dim sData As Variant: sData = srg.Value
    
    ' Define the destination array ('dData').
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' 6. Write the values from the source array to the destination array.
    
    ' Write headers.
    
    Dim sValue As Variant
    Dim sv As Long
    
    For sv = 0 To svUpper
        If svCols(sv) = 0 Then ' unpivot
            sValue = duTitle
        Else ' value
            sValue = sData(1, svCols(sv))
        End If
        dData(1, sv + 1) = sValue
    Next sv
    
    ' Write data.
    
    Dim dr As Long: dr = 1 ' headers are already written
    
    Dim sr As Long
    
    For sr = 2 To srCount
        For su = 0 To suUpper
            sValue = sData(sr, suCols(su))
            If Not IsEmpty(sValue) Then
                dr = dr + 1
                For sv = 0 To svUpper
                    If svCols(sv) = 0 Then ' unpivot
                        sValue = sData(sr, suCols(su))
                    Else ' value
                        sValue = sData(sr, svCols(sv))
                    End If
                    dData(dr, sv + 1) = sValue
                Next sv
            End If
        Next su
    Next sr
    
    ' 7. Write the results to the destination worksheet.
    
    ' Reference the destination worksheet.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    ' Clear previous data.
    dws.Cells.Clear
    
    ' Write the new values.
    With dws.Range(dFirstCellAddress).Resize(, dcCount)
        ' Write the values from the destination array
        ' to the destination worksheet.
        .Resize(drCount).Value = dData
        ' Apply simple formatting:
        ' Headers.
        .Font.Bold = True
        ' Entire Columns
        .EntireColumn.AutoFit
    End With
    
    ' Save the workbook.
    'wb.Save
    
    ' 8. Inform to not wonder if the code has run or not.
    
    MsgBox "Data transformed.", vbInformation  
End Sub

Would it help to simplify if you replace the header names color1 > blue etc. — Anonymous
– Anonymous, Commented Jul 3, 2022 at 2:16
What about to loop through unit 1 .. 4 per row and and add corresponding color (1st color column not null, 2nd not null, … ) as a new combo. Unpivot these 4 lines then separate combo back to unit und color? — Anonymous
– Anonymous, Commented Jul 3, 2022 at 9:22
It should be pretty easy to do in Power Query, available in Excel 2010+. But your output doesn't look like a regular unpivot. In particular, it appears you want to eliminate the empty columns in the color rows also. — Ron Rosenfeld
– Ron Rosenfeld, Commented Jul 3, 2022 at 11:12
1. I think the same way as Ron, that with PowerQuery the transformation here can be accomplished in an easier way than with VBA. 2. To me, table 1 is not a “complete” pivot table with 2 categories as it is not nested, really. The easiest way to see what I mean is, to use table2 and ”ask” Excel to create a pivot table assigning unit name and color as “column labels”. — Anonymous
– Anonymous, Commented Jul 3, 2022 at 16:51
It would be a lot easier to help you, with specifics, had you posted your original data as text. Your screenshot of data is virtually useless for doing proper troubleshooting. It cannot be copy/pasted into a worksheet. Having to manually enter the data is discouraging to those who might assist you. To make the data useful edit your question to post it as text, perhaps using this Markdown Tables Generator. — Ron Rosenfeld
– Ron Rosenfeld, Commented Jul 3, 2022 at 17:14

karma · Accepted Answer · 2022-07-03 16:33:21Z

Sub test()
Dim sh1 As Worksheet: Dim sh2 As Worksheet: Dim hdr
Dim rgUnit As Range: Dim rgColor As Range: Dim cell As Range
Dim i As Long: Dim cnt As Long: Dim r As Long: Dim arr

'setting the sheet into variable - change if needed
Set sh1 = Sheets("Sheet1"): Set sh2 = Sheets("Sheet2")

'clear all cells in sh2
sh2.Cells.ClearContents

'the header which will be in sh2 coming from sh1 header as hdr variable
hdr = Array("Family", "Company Name", "Unit 1 name", "Unit 2 Name", "Unit 3 Name", "Unit 4 Name", "First Name", "Last Name", "Status", "Email", "Phone", "Color 1", "Color 2", "Color 3", "Color 4")

'put the data from sh1 to sh2 according to the header name defined in arr
For i = LBound(hdr) To UBound(hdr)
sh1.Columns(sh1.Rows(1).Find(hdr(i)).Column).Copy Destination:=sh2.Columns(i + 1)
Next

'start row
r = 2

Do

    'set the range for Unit Name and Color according to the looped row into variable rgUnit and rgColor
    Set rgUnit = sh2.Range(sh2.Cells(r, 3), sh2.Cells(r, 6))
    Set rgColor = rgUnit.Offset(0, 9)

    'count how many data in rgUnit as cnt variable
    cnt = Application.CountA(rgUnit)
    
        'if cnt > 1, copy the looped row then insert under it as many as cnt - 1
        If cnt > 1 Then
            sh2.Rows(r).Copy
            sh2.Rows(r + 1 & ":" & r + cnt - 1).Insert Shift:=xlDown
            Application.CutCopyMode = False
        End If

    'fill the unit name
    Set arr = CreateObject("scripting.dictionary")
    For Each cell In rgUnit.SpecialCells(xlCellTypeConstants): arr.Item(cell.Value) = 1: Next
    rgUnit.Resize(cnt, 1).Value = Application.Transpose(arr.keys)
        
    'fill the color
    Set arr = CreateObject("scripting.dictionary")
    For Each cell In rgColor.SpecialCells(xlCellTypeConstants): arr.Item(cell.Value) = 1: Next
    rgColor.Resize(cnt, 1).Value = Application.Transpose(arr.keys)

    'increase the row value by add the cnt value
    r = r + cnt
        
Loop Until Application.CountA(sh2.Range(sh2.Cells(r, 3), sh2.Cells(r, 6))) = 0 'finish the loop when rgUnit has no data

'delete unneeded column
rgUnit.Resize(rgUnit.Rows.Count, 3).Offset(0, 1).EntireColumn.Delete
rgColor.Resize(rgColor.Rows.Count, 3).Offset(0, 1).EntireColumn.Delete

'give the correct name for unit and color header in sh2
sh2.Range("C1").Value = "Unit Name"
sh2.Range("i1").Value = "Color"

End Sub

The sub assumed :

each person name at lease has one unit
if he has one unit name then he has one color , if he has two unit name then he has two colors, and so on.
each item in the hdr variable is exactly the same string which is in sheet1 header.

The process is explained in the commented line of the sub.
While in Sheet2, please step run the code and see what happen to the sheet when it step the line.

if the line Set arr = CreateObject("scripting.dictionary") throw you an error, please try the substitute code below:

'fill the unit name
Set rgFill = rgUnit.Resize(1, 1)
For Each cell In rgUnit.SpecialCells(xlCellTypeConstants)
    rgFill.Value = cell.Value
    Set rgFill = rgFill.Offset(1, 0)
Next

'fill the color
Set rgFill = rgColor.Resize(1, 1)
For Each cell In rgColor.SpecialCells(xlCellTypeConstants)
    rgFill.Value = cell.Value
    Set rgFill = rgFill.Offset(1, 0)
Next

And change the dim arr to dim rgFill as range

I'm sorry I don't know why it happen like that. After google search, the only thing I know it's because if you use Mac. I will try to edit the code if you use Mac, hence the code can't use the scripting.dictionary.
@blackmamba89, as long as the data count are all the same, I think you can apply to more than just unit name and color. Example you have another 4 columns header for "shape" in Sheet1. So, if for example the person has 3 unit name, 3 colors, then he also must has 3 shapes. Define it first the rgShape variable by telling it what column of row(r) is the range of rgShape. Then add the line for "fill the shape" similar like the line to fill the unit name and color. Also similar code to delete uneeded column. Don't forget to add the name of the shape-1 to shape-4 header to hdr array variable.
btw, what is "Rgb" variable ? Did you mean you use Rgb instead of rgFill variable ?
@blackmamba89, you're welcome. I hope the code can be applied to your real data.

Collectives™ on Stack Overflow

Unpivoting two categories of columns using VBA

1 Answer 1

9 Comments

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

9 Comments

Related