寻求Excel中可根据单列重复值将整行移至新工作表的Macro

操作步骤 #

• 打开需要处理的Excel文件，按下Alt+F11组合键调出VBA编辑器
• 在左侧工程面板右键点击当前工作簿名称，依次选择「插入」-「模块」，将下方代码完整粘贴到弹出的模块编辑窗口中

Sub 移动重复行到新表()
    ' 可根据需求修改以下配置参数
    Const colNum As Integer = 1       ' 需要判断重复的列号，1代表A列，2代表B列，以此类推
    Const startRow As Long = 2        ' 数据起始行，默认第2行（第1行作为表头不参与判断）
    Const targetSheetName As String = "重复记录" ' 存放重复行的工作表名称
    
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, i As Long, targetNextRow As Long
    Dim valueDict As Object, currentVal
    Set valueDict = CreateObject("Scripting.Dictionary")
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 绑定数据源工作表为当前活动表，也可直接写工作表名，比如Set wsSource = Sheets("Sheet1")
    Set wsSource = ActiveSheet
    
    ' 检查目标存放表是否存在，不存在则新建
    On Error Resume Next
    Set wsTarget = Sheets(targetSheetName)
    If wsTarget Is Nothing Then
        Set wsTarget = Sheets.Add(after:=Sheets(Sheets.Count))
        wsTarget.Name = targetSheetName
        ' 把表头复制到目标表
        wsSource.Rows(1).Copy wsTarget.Rows(1)
        targetNextRow = 2
    Else
        targetNextRow = wsTarget.Cells(wsTarget.Rows.Count, colNum).End(xlUp).Row + 1
    End If
    On Error GoTo 0
    
    ' 获取源表最后一行行号
    lastRow = wsSource.Cells(wsSource.Rows.Count, colNum).End(xlUp).Row
    
    ' 从最后一行往上遍历，避免删除行导致行号错乱漏判
    For i = lastRow To startRow Step -1
        currentVal = wsSource.Cells(i, colNum).Value
        ' 跳过空值单元格
        If currentVal <> "" Then
            If valueDict.Exists(currentVal) Then
                ' 值已存在，判定为重复行，剪切到目标表后删除源表对应行
                wsSource.Rows(i).Cut wsTarget.Rows(targetNextRow)
                wsSource.Rows(i).Delete
                targetNextRow = targetNextRow + 1
            Else
                ' 值第一次出现，存入字典留作比对基准
                valueDict.Add currentVal, 1
            End If
        End If
    Next i
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "处理完成，共移动" & targetNextRow - 2 & "条重复记录", vbInformation
End Sub

自定义调整说明 #

• 如果你需要判断非A列的重复值，直接修改代码开头colNum的赋值即可，例如要判断D列重复就将值改为4
• 如果你的数据没有表头，直接把startRow的值改为1即可
• 代码运行时会自动创建存放重复记录的工作表，不需要提前手动新建；如果已经存在同名表，会把重复行追加到该表现有数据的末尾

运行方法 #

• 代码粘贴完成后，直接在VBA编辑器按F5即可运行；也可以回到Excel主界面，按Alt+F8选中名为「移动重复行到新表」的宏，点击「执行」按钮

注意：运行宏前建议先备份原文件，避免误操作导致数据丢失。3000行数据的处理速度在1秒以内，不会出现卡顿。处理完成后原表仅保留每个重复值第一次出现的记录，其余重复行全部转移到目标工作表。

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