需要 Excel 宏来复制列中标记的每个“X”的行（VBA）

Question

需要一个宏来帮助我处理数据，其中添加 X 来标记该行属于哪个组。例如：

数据还包含更多列，但这只是其要点。它们用 X 标记行所属的组，组 ID 位于标题中。如果它可以复制标题并将其替换为“X”，那就太好了。只需要在列中标记每个组重复的行即可。

这需要使用 VBA，而不是 SQL。代码：

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

它没有对我的代码做任何事情。

Answer 1

Sub Demo()    
    Dim i as Long, j as Long
    Dim arrData, rngData as Range
    Dim arrRes, iR as Long
    Dim LastRow as Long, RowCnt As Long, ColCnt As Long
    Set rngData = ActiveSheet.Range("A1").CurrentRegion
    arrData = rngData.Value
    RowCnt = UBound(arrData)
    ColCnt = UBound(arrData,2)
    Redim arrRes(1 to RowCnt*(ColCnt-3), 1 To 4)
    arrRes(1,1)="Group":arrRes(1,2)="FirstName"
    arrRes(1,3)="LastName":arrRes(1,4)="PhoneNumber"
    iR = 1
    For i = LBound(arrData)+1 To UBound(arrData)
        For j = LBound(arrData,2) To ColCnt-3
          If Ucase(arrData(i, j)) = "X" Then
            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