Excel下拉列表选指定值时自动复制插入行的实现及问题排查

原有代码的核心问题 #

• 循环方向错误：从上往下遍历插入行时，新插入的行会打乱后续行号，导致重复判断同一行，最终插入多行
• 语法错误：EndXlDown应为End(xlDown)，Rowoffset未赋值，xlShiftDown前存在多余空格
• 列匹配错误：需求中下拉列表在第2列（B列），原有代码判断的是E列
• 事件递归问题：Worksheet_Change中修改单元格会再次触发自身事件，导致无限循环插入行
• 缺少复制逻辑：原有代码仅插入空行，没有复制原行内容

修正后代码 #

1. 实时触发版本（选择下拉时自动执行） #

将以下代码放在Customer工作表的代码模块中，不需要额外调用Addline过程：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 仅处理单个单元格修改、且修改的是第2列（产品列，可自行调整列号）的场景
    If Target.Count <> 1 Or Target.Column <> 2 Then Exit Sub
    
    ' 关闭事件防止递归触发
    Application.EnableEvents = False
    
    ' 出错时自动恢复事件触发
    On Error GoTo ErrHandler
    
    If Target.Value = "Apple" Then
        ' 在下一行插入空行
        Target.Offset(1, 0).EntireRow.Insert Shift:=xlShiftDown
        ' 复制当前行内容到新插入的行
        Target.EntireRow.Copy Destination:=Target.Offset(1, 0).EntireRow
    End If
    
ErrHandler:
    Application.EnableEvents = True
End Sub

2. 批量处理版本（处理已有历史数据） #

如果需要给表格中已经存在的所有Apple行批量插入重复行，使用以下代码：

Sub BatchAddLineForApple()
    Dim LR As Long, i As Long
    ' 获取产品列最后一行行号
    LR = Sheets("Customer").Cells(Rows.Count, "B").End(xlUp).Row
    
    Application.EnableEvents = False
    On Error GoTo ErrHandler
    
    ' 从最后一行往上遍历，避免插入行打乱行号，起始行可根据表头实际位置调整，示例从第2行开始
    For i = LR To 2 Step -1
        If Sheets("Customer").Range("B" & i).Value = "Apple" Then
            Sheets("Customer").Range("B" & i).Offset(1, 0).EntireRow.Insert Shift:=xlShiftDown
            Sheets("Customer").Range("B" & i).EntireRow.Copy Destination:=Sheets("Customer").Range("B" & i).Offset(1, 0).EntireRow
        End If
    Next i
    
ErrHandler:
    Application.EnableEvents = True
End Sub

注意事项 #

• 如果产品列不是B列，将代码中Target.Column <> 2的数值修改为对应列号即可
• 批量处理的起始行可根据实际需求调整，比如要从第7行开始处理，就将循环条件改为For i = LR To 7 Step -1

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