Need a macro that will help me process data where they add an X to mark which group the row belongs to. For example:
The data comes with many more columns but that’s just the gist of it. They mark with an X the groups the rows belong to and the group ID is in the header. Would be great if it could copy the header and replace it with the “X”. Just need the rows duplicated per group marked in the column.
This needs to be in VBA not SQL. Code:
Sub DuplicateRowsPerCategory()
Dim lastRow As Long
Dim i As Long, j As Long, k As Long
Dim ws As Worksheet
Dim catHeaders() As String
' Set the worksheet where your data is located
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your sheet name
' Determine the last row with data
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' Array to store category headers
ReDim catHeaders(1 To lastRow, 1 To 100) ' Assuming maximum 100 columns
' Loop through each row
For i = 2 To lastRow ' Assuming headers are in row 1
k = 1
' Loop through each column to find categories marked with "X"
For j = 2 To ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column
If ws.Cells(i, j).Value = "X" Then
' Duplicate the row
ws.Rows(i).Copy
ws.Rows(i + k).Insert Shift:=xlDown
' Store category header for this row
catHeaders(i + k, k) = ws.Cells(1, j).Value
k = k + 1
End If
Next j
' Replace "X" with empty in original row
For j = 2 To ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column
If ws.Cells(i, j).Value = "X" Then
ws.Cells(i, j).Value = ""
End If
Next j
Next i
' Add category headers as new columns
For i = 1 To lastRow
For j = 1 To 100
If catHeaders(i, j) <> "" Then
ws.Cells(i, ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column + 1).Value = catHeaders(i, j)
End If
Next j
Next i
' Remove empty columns
For j = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column To 2 Step -1
If WorksheetFunction.CountA(ws.Columns(j)) = 0 Then
ws.Columns(j).Delete
End If
Next j
' Clear clipboard
Application.CutCopyMode = False
MsgBox "Rows duplicated per category successfully!", vbInformation End Sub
It’s not doing anything to my code.
2
VBA Code
- Using an array to load and transform data in memory is a more efficient approach.
Microsoft documentation:
Range.Resize property (Excel)
Range.CurrentRegion property (Excel)
Option Explicit
Sub Demo()
Dim i As Long, j As Long
Dim arrData, arrRes, iR As Long
Dim RowCnt As Long, ColCnt As Long
' load data into array
arrData = ActiveSheet.Range("A1").CurrentRegion.Value
RowCnt = UBound(arrData)
ColCnt = UBound(arrData, 2)
ReDim arrRes(1 To RowCnt * (ColCnt - 3), 1 To 4)
' header
arrRes(1, 1) = "Group": arrRes(1, 2) = arrData(1, ColCnt - 2)
arrRes(1, 3) = arrData(1, ColCnt - 1): arrRes(1, 4) = arrData(1, ColCnt)
iR = 1
' loop through table
For i = LBound(arrData) + 1 To UBound(arrData)
For j = LBound(arrData, 2) To ColCnt - 3
If UCase(arrData(i, j)) = "X" Then
' populate output array
iR = iR + 1
arrRes(iR, 1) = arrData(1, j)
arrRes(iR, 2) = arrData(i, ColCnt - 2)
arrRes(iR, 3) = arrData(i, ColCnt - 1)
arrRes(iR, 4) = arrData(i, ColCnt)
End If
Next j
Next i
Sheets.Add
' write output to sheet
Range("A1").Resize(iR, 4) = arrRes
End Sub
Power Query
let
Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Changed Type" = Table.TransformColumnTypes(Source,{{"Group 1", type text}, {"Group 2", type text}, {"Group 3", type text}, {"First Name", type text}, {"Last Name", type text}, {"Phone Number", type text}}),
#"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Changed Type", {"First Name", "Last Name", "Phone Number"}, "Group", "Value"),
#"Removed Columns" = Table.RemoveColumns(#"Unpivoted Other Columns",{"Value"}),
#"Reordered Columns" = Table.ReorderColumns(#"Removed Columns",{"Group", "First Name", "Last Name", "Phone Number"})
in
#"Reordered Columns"