查找重复值并复制重复行至指定工作表的VBA报错排查

问题背景 #

Sheet1存储了14万+行主数据，结构如下：

需求是将所有**ID Number重复的行（包括初始行和新增重复行）**复制到名为"Duplicate"的工作表。例如新增以下数据后，Briana（ID124）和Charlie（ID125）的行需要全部复制：

运行以下VBA代码时触发运行时错误'1004'，提示"That command cannot be used on multiple selection"：

Option Explicit

Sub FilterAndCopy()

Dim wstSource As Worksheet, _
    wstOutput As Worksheet
Dim rngMyData As Range, _
    helperRng As Range

Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Duplicate")

Application.ScreenUpdating = False

With wstSource
    Set rngMyData = .Range("A1:S" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)

With helperRng
    .FormulaR1C1 = "=if(countif(C1,RC1)>1,"""",1)"
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(2, 1)
    .ClearContents
End With

Application.ScreenUpdating = True

End Sub

错误原因 #

1. 公式范围错误：原代码用C1（第一列）作为统计范围，但实际需要统计的是ID Number列（第五列），导致辅助列标记逻辑错误，无法正确识别所有重复行。
2. 多区域复制限制：.SpecialCells(xlCellTypeBlanks).EntireRow会选中不连续的多行，当数据量达到14万行时，Excel对这类多区域的直接复制操作有严格限制，触发1004错误。

修正后的代码 #

以下代码针对大数据量优化，避免多区域选择问题，同时准确识别所有重复行：

Option Explicit

Sub CopyAllDuplicateRows()
    Dim wstSource As Worksheet, wstOutput As Worksheet
    Dim lastRow As Long, idCol As Integer
    Dim rngData As Range
    
    ' 绑定源表和输出表
    Set wstSource = ThisWorkbook.Worksheets("Sheet1")
    Set wstOutput = ThisWorkbook.Worksheets("Duplicate")
    
    ' 关闭屏幕刷新和自动计算，提升大数据量处理速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 清空输出表旧数据（保留第一行表头）
    wstOutput.Range("A2:" & wstOutput.Cells(wstOutput.Rows.Count, wstOutput.Columns.Count).Address).ClearContents
    
    ' 自动定位ID Number列（无需硬编码列号）
    idCol = wstSource.Rows(1).Find(What:="ID Number", LookIn:=xlValues, LookAt:=xlWhole).Column
    lastRow = wstSource.Cells(wstSource.Rows.Count, idCol).End(xlUp).Row
    
    ' 定义完整数据范围（A列到S列，包含表头）
    Set rngData = wstSource.Range(wstSource.Cells(1, 1), wstSource.Cells(lastRow, "S"))
    
    ' 添加辅助列标记所有重复行
    With rngData.Offset(0, rngData.Columns.Count).Resize(, 1)
        ' 公式逻辑：当前行ID在ID列中出现次数>1则标记为TRUE
        .FormulaR1C1 = "=COUNTIF(C" & idCol & ",RC" & idCol & ")>1"
        .Value = .Value ' 转换为静态值，避免后续计算干扰
        
        ' 筛选出标记为TRUE的重复行
        rngData.AutoFilter Field:=.Column, Criteria1:=True
        
        ' 复制筛选后的可见行到输出表
        On Error Resume Next ' 处理无重复行的边界情况
        rngData.SpecialCells(xlCellTypeVisible).Copy Destination:=wstOutput.Cells(2, 1)
        On Error GoTo 0
        
        ' 清除筛选状态和辅助列内容
        wstSource.AutoFilterMode = False
        .ClearContents
    End With
    
    ' 恢复默认设置
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "重复行复制完成", vbInformation
End Sub

代码说明 #

• 自动定位ID列：通过Find方法找到ID Number列的位置，无需硬编码列号，适配表头位置变化。
• 筛选式复制：使用AutoFilter筛选重复行，避免多区域选择的限制，更适合14万行的大数据量场景。
• 性能优化：关闭屏幕刷新和自动计算，大幅提升运行速度。
• 边界处理：添加错误捕获，避免无重复行时触发报错。

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