-
Jul 3rd, 2022, 12:34 AM
#1
Thread Starter
New Member
Unpivoting 2 categories of columns using vba
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
-
Jul 3rd, 2022, 03:50 AM
#2
Re: Unpivoting 2 categories of columns using vba
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
to hunt a species to extinction is not logical !
since 2010 the number of Tigers are rising again in 2016 - 3900 were counted. with Baby Callas it's 3901, my wife and I had 2-3 months the privilege of raising a Baby Tiger.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|