this is my 2nd attempt at this. Apparently, I didn't have proper "stackoverflow etiquette" according to some users. However, I'm giving it another shot. I checked some other posts but none work to accomplish what I'm trying to accomplish. Basically, I have different categories as listed in columns: Company name, 1st name, last name, number of units, unit 1, unit 2, unit 3, unit 4, family, email, etc. Each company has its on row. However some companies can have multiple units at the same time. I want to separate the companies by their units. Below I have a picture of Sheet1, and then when I start the vba code, I want it to be copied over to Sheet2 to look like the 2nd picture. I have also attached my code below as well for reference. Everything on the spreadsheets are made up and fake. It's just an example for a bigger project I'm working on. The problem with my code is that it just displaces the columns but doesn't condense the columns I want into one column. Also, I don't know how to add code for copying from sheet to sheet. I am open to any suggestions/feedback or links to other posts. I'm new to this. Any help is greatly appreciated!
Sub Button2_Click()
Dim cr As Long 'current row
Dim cc As Long 'current column
For cr = 2 To 11
For cc = 8 To 11 Step 2
If Cells(cr, cc).Value = "R" Then
'make column 13 (M) in current row = unit
Cells(cr, 13).Value = Cells(1, cc).Value
End If
Next
Next
End Sub
CodePudding user response：
Transform Data (Unpivot)
- Adjust (play with) the values in the constants section.
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)
' 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)
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
CodePudding user response：
VBA here is a sledgehammer to crack a nut.
It is easily done with a Pivot Table.
To get the rows with multiple units to have separate records for each unit:
in M1 put Use_Unit.
In M2 =H2 and drag down.
Then in a area below the current data (say starting at row 1002):
In A1002 =A2 and drag across and down, except that in M1002 put =if(I2="","Ignore", I2) (or I1002).
Similarly for third and fourth blocks, looking ad J and K respectively.
Then do the Pivot Table, and filter out Unit_Use = Ignore