需求：编写Excel VBA宏按标记X的列复制对应行

问题背景 #

需求：Excel数据中，每行用"X"标记所属分组（分组ID在第1行表头），需实现：

• 每行中每个标记"X"的分组，复制该行生成新行
• 新行中用对应分组的表头文本替换"X"
• 原行清空所有"X"标记

用户提供的VBA代码执行后无任何效果，需排查修复。

原代码核心问题 #

• 循环范围未动态更新：初始获取的lastRow是固定值，插入新行后实际数据行数增加，但循环仍只到原lastRow，导致新增行和后续未处理行被遗漏。
• 分类头存储数组逻辑错误：catHeaders数组按原lastRow初始化，插入的行号超出数组范围，无法正确存储分类头，后续也无法写入。
• 分类头写入范围错误：写入分类头的循环仅遍历原lastRow范围内的行，完全漏掉了插入的新行。
• 字符串比较未考虑大小写：若数据中是小写"x"，原代码的"X"匹配会失效。

修复后的VBA代码 #

Sub DuplicateRowsPerCategory()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim catHeader As String
    
    ' 设置目标工作表，按需修改
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 关闭屏幕刷新提升效率
    Application.ScreenUpdating = False
    
    ' 从最后一行往上循环，避免插入行影响索引
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    For i = lastRow To 2 Step -1
        lastCol = ws.Cells(i, ws.Columns.Count).End(xlToLeft).Column
        ' 遍历当前行的分组列（从第2列开始）
        For j = lastCol To 2 Step -1
            ' 匹配大小写不敏感的X/x
            If UCase(ws.Cells(i, j).Value) = "X" Then
                catHeader = ws.Cells(1, j).Value
                ' 复制当前行并插入到下方
                ws.Rows(i).Copy
                ws.Rows(i + 1).Insert Shift:=xlDown
                ' 替换新行中的X为分组表头
                ws.Cells(i + 1, j).Value = catHeader
                ' 清空原行的X标记
                ws.Cells(i, j).Value = ""
            End If
        Next j
    Next i
    
    ' 删除空列（从右往左删）
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    For j = lastCol To 2 Step -1
        If WorksheetFunction.CountA(ws.Columns(j)) = 0 Then
            ws.Columns(j).Delete
        End If
    Next j
    
    ' 恢复屏幕刷新，清空剪贴板
    Application.ScreenUpdating = True
    Application.CutCopyMode = False
    
    MsgBox "分组行复制完成！", vbInformation
End Sub

修复说明 #

• 从下往上循环行：避免插入新行后，后续行的索引被打乱，确保所有行都能被处理。
• 即时替换分组头：插入新行后直接将X替换为对应表头，无需额外数组存储，逻辑更简洁。
• 大小写不敏感匹配：用UCase()统一转换为大写，兼容小写"x"的情况。
• 动态更新行列范围：每次循环都重新获取当前行的最后列，避免因删除/插入操作导致的范围错误。
• 关闭屏幕刷新：提升宏的执行速度，避免界面闪烁。

内容的提问来源于stack exchange，提问作者user16201107