Excel VBA宏实现多工作表对比AB列查找重复项并高亮上移

功能适配说明 #

• 自动适配Sheet1到Sheet10的所有存在的工作表，工作表数量不足10个也可正常运行
• 对比A列与B列内容判定重复：A列值在B列中存在即判定为重复
• 重复值对应的A列单元格自动标注黄色高亮
• 所有重复行将自动移动到工作表从A1开始的首行区域

使用方法 #

1. 打开目标Excel文件，按下Alt + F11调出VBA编辑器
2. 右键当前工作簿名称，选择「插入」-「模块」
3. 将下方代码复制粘贴到新建的模块中
4. 按下F5运行ProcessAllTargetSheets宏即可完成处理

完整VBA代码 #

Sub ProcessAllTargetSheets()
    Dim ws As Worksheet
    Dim i As Integer
    '遍历Sheet1到Sheet10
    For i = 1 To 10
        On Error Resume Next
        Set ws = ThisWorkbook.Worksheets("Sheet" & i)
        On Error GoTo 0
        '如果工作表存在则处理
        If Not ws Is Nothing Then
            ProcessSingleSheet ws
            Set ws = Nothing
        End If
    Next i
    MsgBox "所有工作表处理完成！", vbInformation
End Sub

Sub ProcessSingleSheet(ws As Worksheet)
    Dim lastRow As Long
    Dim dict As Object
    Dim i As Long, dupCount As Long
    Dim tempRng As Range
    
    With ws
        '获取当前工作表最后一行
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastRow < 1 Then Exit Sub
        
        '创建字典存储B列所有值
        Set dict = CreateObject("Scripting.Dictionary")
        For i = 1 To .Cells(.Rows.Count, "B").End(xlUp).Row
            If Trim(.Cells(i, "B").Value) <> "" And Not dict.exists(Trim(.Cells(i, "B").Value)) Then
                dict.Add Trim(.Cells(i, "B").Value), True
            End If
        Next i
        
        '先清除原有高亮
        .Columns("A").Interior.ColorIndex = xlColorIndexNone
        
        '标记重复值并统计重复行数量
        dupCount = 0
        For i = 1 To lastRow
            If Trim(.Cells(i, "A").Value) <> "" And dict.exists(Trim(.Cells(i, "A").Value)) Then
                .Cells(i, "A").Interior.Color = RGB(255, 255, 0) '黄色高亮
                dupCount = dupCount + 1
                '标记待移动行
                If tempRng Is Nothing Then
                    Set tempRng = .Rows(i)
                Else
                    Set tempRng = Union(tempRng, .Rows(i))
                End If
            End If
        Next i
        
        '将重复行移动到首行区域
        If Not tempRng Is Nothing And dupCount > 0 Then
            tempRng.Cut
            .Rows(1).Insert Shift:=xlDown
            '清除移动后产生的多余空行
            .Rows(dupCount + 1 & ":" & dupCount + tempRng.Areas.Count).Delete
        End If
    End With
    Set dict = Nothing
    Set tempRng = Nothing
End Sub

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