求助：实现Excel重复序列号对应行的差异高亮动态VBA代码

以下是修改后的VBA代码，实现按A列重复序列号分组对比并高亮差异：

Sub HighlightDuplicateSerialDifferences()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim serialDict As Object
    Dim key As Variant, rowList As Variant
    Dim baseRow As Long, compareRow As Long
    Dim diffRange As Range
    Dim cell As Range
    
    ' 设置当前工作表，可根据需要修改
    Set ws = ActiveSheet
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 清除之前的高亮格式
    ws.UsedRange.Interior.ColorIndex = xlColorIndexNone
    
    ' 获取数据区域的最后一行和最后一列
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' 创建字典存储序列号对应的行号
    Set serialDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历A列，分组存储行号
    For i = 2 To lastRow ' 假设第一行是表头，从第二行开始
        serialValue = ws.Cells(i, "A").Value
        If serialValue <> "" Then
            If serialDict.Exists(serialValue) Then
                ' 已有该序列号，追加行号
                serialDict(serialValue) = serialDict(serialValue) & "," & i
            Else
                ' 首次出现，添加行号
                serialDict(serialValue) = CStr(i)
            End If
        End If
    Next i
    
    ' 遍历每个序列号组
    For Each key In serialDict.Keys
        rowList = Split(serialDict(key), ",")
        ' 仅处理有重复的组（行号数量≥2）
        If UBound(rowList) >= 1 Then
            baseRow = CLng(rowList(0)) ' 取组内第一行作为基准行
            ' 对比组内其他行与基准行的差异
            For j = 1 To UBound(rowList)
                compareRow = CLng(rowList(j))
                ' 获取当前行与基准行的差异单元格
                On Error Resume Next
                Set diffRange = ws.Range(ws.Cells(compareRow, 2), ws.Cells(compareRow, lastCol)).ColumnDifferences(Comparison:=ws.Cells(baseRow, 2))
                On Error GoTo 0
                
                If Not diffRange Is Nothing Then
                    ' 高亮对比行的差异单元格
                    diffRange.Interior.ColorIndex = 6
                    ' 高亮基准行对应的差异单元格
                    For Each cell In diffRange
                        ws.Cells(baseRow, cell.Column).Interior.ColorIndex = 6
                    Next cell
                End If
            Next j
        End If
    Next key
    
    Application.ScreenUpdating = True
    Set serialDict = Nothing
    Set ws = Nothing
End Sub

关键修改说明 #

• 按序列号分组：使用Scripting.Dictionary将A列相同序列号的行号归类，彻底解决原代码逐两行对比的局限性
• 清除旧格式：运行前先清除所有单元格背景色，避免之前的高亮残留干扰结果
• 动态范围：自动识别数据的最后一行和最后一列，无需手动指定固定范围（如原代码的D2:AZ3）
• 精准差异高亮：对每个重复组，以组内第一行为基准，对比其他行的差异并同时高亮基准行和对比行的对应差异单元格

内容的提问来源于stack exchange，提问作者Ryan Data Guy