Unpivoting 2 categories of columns using vba - excel

Question

I have code that unpivots columns with the category of Line1, Line2, Line3, Line4 into one Column called Lines. This code accomplishes that goal. However, I also have other another category I want to unpivot as well but I'm not sure how to unpivot two categories at the same time. My code only unpivots one category. I want it to unpivot two: Line1, Line2, Line3, Line4 & Color1, Color2, Color3, Color4 -----> Unit Name & Color (each with their own columns). Very hard to explain, so I have attached my code and also a few tables pictures. The 2nd pic is how I want to look. As I stated before, the code works to unpivot Columns H-K (s/o to VBasic 2008 for the help last time), but I also want to unpivot Columns N-Q as well. Any help or suggestions will be greatly appreciated. Keep in mind I tried using the table function on here but it doesn't work very well for me due to the size of my data so apologies for the inconvenience. I will gladly upvote your responses if you help me.
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

Answer 1

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