基于Email列的Excel CSV去重并拆分至新工作表的VBA需求

需求说明 #

• 在名为OldList的工作表中，以第1行为表头，仅按Email列判断重复项，其他列内容不影响去重逻辑
• 在同一工作簿新建NewList工作表，存放去重后的数据（仅保留每个Email首次出现的条目）
• 在同一工作簿新建Removed Duplicates工作表，存放被移除的重复项，并附加其在OldList中的原行号位置

示例输入（OldList工作表） #

期望输出1（NewList工作表） #

期望输出2（Removed Duplicates工作表） #

现有基础代码 #

Sub test()
ActiveSheet.Range("A:C").RemoveDuplicates Columns:=2, Header:=xlYes
End Sub

完善后的VBA宏代码 #

Sub RemoveDuplicatesWithTracking()
    Dim wsOld As Worksheet, wsNew As Worksheet, wsRemoved As Worksheet
    Dim lastRow As Long, i As Long, newRow As Long, removedRow As Long
    Dim emailDict As Object
    Dim currentEmail As String, oldLocation As String
    
    ' 初始化字典，用于记录已出现的Email
    Set emailDict = CreateObject("Scripting.Dictionary")
    
    ' 定位到OldList工作表，不存在则提示退出
    On Error Resume Next
    Set wsOld = ThisWorkbook.Worksheets("OldList")
    On Error GoTo 0
    If wsOld Is Nothing Then
        MsgBox "未找到名为OldList的工作表，请确认后重试！"
        Exit Sub
    End If
    
    ' 创建或激活NewList工作表，清空原有内容
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets("NewList")
    If Err.Number <> 0 Then
        Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsNew.Name = "NewList"
    End If
    On Error GoTo 0
    wsNew.Cells.Clear
    
    ' 创建或激活Removed Duplicates工作表，清空原有内容
    On Error Resume Next
    Set wsRemoved = ThisWorkbook.Worksheets("Removed Duplicates")
    If Err.Number <> 0 Then
        Set wsRemoved = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsRemoved.Name = "Removed Duplicates"
    End If
    On Error GoTo 0
    wsRemoved.Cells.Clear
    
    ' 复制表头：OldList表头到NewList，到Removed表时追加"Old location"列
    wsOld.Rows(1).Copy Destination:=wsNew.Rows(1)
    wsOld.Rows(1).Copy Destination:=wsRemoved.Rows(1)
    wsRemoved.Cells(1, wsOld.UsedRange.Columns.Count + 1).Value = "Old location"
    
    ' 获取OldList数据的最后一行行号
    lastRow = wsOld.Cells(wsOld.Rows.Count, "A").End(xlUp).Row
    newRow = 2 ' NewList数据起始行
    removedRow = 2 ' Removed表数据起始行
    
    ' 遍历所有数据行，分类处理
    For i = 2 To lastRow
        currentEmail = Trim(wsOld.Cells(i, 2).Value) ' 读取当前行Email（第2列，需调整请修改数字2）
        
        ' 首次出现的Email：复制到NewList并记录到字典
        If Not emailDict.Exists(currentEmail) Then
            emailDict.Add currentEmail, True
            wsOld.Rows(i).Copy Destination:=wsNew.Rows(newRow)
            newRow = newRow + 1
        Else
            ' 重复的Email：复制到Removed表并标注原行号
            wsOld.Rows(i).Copy Destination:=wsRemoved.Rows(removedRow)
            oldLocation = "Row " & i
            wsRemoved.Cells(removedRow, wsOld.UsedRange.Columns.Count + 1).Value = oldLocation
            removedRow = removedRow + 1
        End If
    Next i
    
    ' 自动调整所有工作表列宽
    wsOld.UsedRange.Columns.AutoFit
    wsNew.UsedRange.Columns.AutoFit
    wsRemoved.UsedRange.Columns.AutoFit
    
    MsgBox "去重完成！NewList为去重后数据，Removed Duplicates为移除的重复项。"
End Sub

使用说明 #

1. 确保CSV数据已导入到名为OldList的工作表，表头在第1行；若Email列不是第2列，修改代码中currentEmail = Trim(wsOld.Cells(i, 2).Value)里的数字2为对应列号
2. 打开Excel VBA编辑器（快捷键Alt+F11），插入新模块，粘贴上述代码
3. 运行RemoveDuplicatesWithTracking宏即可完成操作

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