Excel中对比两个单元格内容并高亮差异的实时格式化方法

要实现两个单元格内短横线分隔内容的实时对比，输入或粘贴时自动高亮差异项，可通过VBA宏完成，具体方案如下：

1. 打开VBA编辑器 #

• 按下 Alt + F11 打开VBA编辑器
• 在左侧「工程资源管理器」中找到目标工作簿，右键插入模块；再右键点击需要生效的工作表（比如Sheet1），选择「查看代码」

2. 编写差异高亮通用函数 #

在插入的模块中粘贴以下代码，用于拆分内容、对比差异并设置高亮格式：

Sub HighlightDifferences(targetCell As Range, compareCell As Range)
    ' 清除单元格原有字体格式
    targetCell.Font.ColorIndex = xlAutomatic
    compareCell.Font.ColorIndex = xlAutomatic
    
    ' 按短横线拆分单元格内容为数组
    Dim targetArr As Variant, compareArr As Variant
    targetArr = Split(targetCell.Value, "-")
    compareArr = Split(compareCell.Value, "-")
    
    Dim i As Integer, j As Integer, isMatch As Boolean
    Dim pos As Integer, lenStr As Integer
    
    ' 标记目标单元格中的差异项（红色高亮）
    For i = LBound(targetArr) To UBound(targetArr)
        isMatch = False
        For j = LBound(compareArr) To UBound(compareArr)
            If Trim(targetArr(i)) = Trim(compareArr(j)) Then
                isMatch = True
                Exit For
            End If
        Next j
        If Not isMatch Then
            pos = InStr(1, targetCell.Value, Trim(targetArr(i)), vbTextCompare)
            lenStr = Len(Trim(targetArr(i)))
            targetCell.Characters(Start:=pos, Length:=lenStr).Font.Color = RGB(255, 0, 0)
        End If
    Next i
    
    ' 标记对比单元格中的差异项（红色高亮）
    For j = LBound(compareArr) To UBound(compareArr)
        isMatch = False
        For i = LBound(targetArr) To UBound(targetArr)
            If Trim(compareArr(j)) = Trim(targetArr(i)) Then
                isMatch = True
                Exit For
            End If
        Next i
        If Not isMatch Then
            pos = InStr(1, compareCell.Value, Trim(compareArr(j)), vbTextCompare)
            lenStr = Len(Trim(compareArr(j)))
            compareCell.Characters(Start:=pos, Length:=lenStr).Font.Color = RGB(255, 0, 0)
        End If
    Next j
End Sub

3. 添加实时触发事件 #

在之前打开的工作表代码窗口中，粘贴以下代码，实现输入/粘贴内容时自动触发对比：

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 设定对比的两列（示例为A列和B列，可自行修改）
    Dim compareCols As Range
    Set compareCols = Intersect(Target, Union(Me.Columns("A"), Me.Columns("B")))
    
    If Not compareCols Is Nothing Then
        Dim cell As Range
        For Each cell In compareCols
            Dim pairedCell As Range
            ' 匹配对应行的另一列单元格
            If cell.Column = 1 Then
                Set pairedCell = Me.Cells(cell.Row, 2)
            Else
                Set pairedCell = Me.Cells(cell.Row, 1)
            End If
            
            ' 仅当配对单元格有内容时执行对比
            If pairedCell.Value <> "" Then
                Call HighlightDifferences(cell, pairedCell)
            End If
        Next cell
    End If
End Sub

关键说明 #

• 代码默认对比A列与B列的对应行，若需其他列，修改Worksheet_Change中的Me.Columns("A")和Me.Columns("B")即可（比如改为Me.Columns("C")和Me.Columns("D")）
• 高亮颜色默认使用红色RGB(255,0,0)，可替换为其他颜色（如黄色RGB(255,255,0)）
• 工作簿需保存为启用宏的工作簿（.xlsm），否则宏无法留存和运行
• 输入或粘贴内容后，只要配对单元格有值，就会自动触发差异高亮

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