Unpivoting 2 categories of columns using vba

[blakemamba89]

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 -----> Line & 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.





Sub Transformation()
' 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

[ChrisE]

in order to create a PIVOT in Excel you have the Data in sheet's ?
so why not use the sheet's you have in order to create the PIVOT.

and this is the .NET Forum not VBA