VBA对比两列表代码异常：无法高亮共性项及复制缺失项至指定工作表

需求说明 #

• 对比Sheet1中A、B列的「列表1」与D、E列的「列表2」
• 高亮两列表的共性项
• 将「列表2独有的项」复制到Sheet2
• 将「列表1独有的项」复制到Sheet3

原代码无法实现预期效果，以下是原代码：

Sub CompareTwoColumns()
    Dim compare1 As Variant, Compare2 As Variant
    Dim r As Integer, q As Integer, dif1 As Integer, dif2 As Integer, m As Integer, n As Integer
    Dim lr1 As Integer, lr2 As Integer
         
    lr1 = Range("a1").End(xlDown).Offset(-1, 0).Row
    lr2 = Range("d1").End(xlDown).Offset(-1, 0).Row
             
    For r = 3 To lr1
        Set compare1 = Cells(r, 1)
        For q = 3 To lr2
            Set Compare2 = Cells(q, 4)
            If compare1 = Compare2 Then GoTo z:
        Next q
        
        Range(Cells(r, 1), Cells(r, 1).End(xlToRight)).Copy
        dif1 = dif1 + 1
        Sheets(2).Cells(dif1, 1).PasteSpecial Paste:=xlPasteValues
z:
        Cells(q, 4).Interior.Color = vbYellow 
    Next r
   
    For m = 3 To lr2
        Set Compare2 = Cells(m, 4)
        For n = 3 To lr1
            Set compare1 = Cells(n, 1)
            If Compare2 = compare1 Then GoTo y:
        Next n

        Range(Cells(n, 4), Cells(n, 4).End(xlToRight)).Copy
        dif3 = dif3 + 1
        Sheets(3).Cells(dif3, 1).PasteSpecial Paste:=xlPasteValues
y:
        Cells(n, 1).Interior.Color = vbYellow
    Next m

End Sub

原代码问题分析 #

1. 行号计算错误：Range("a1").End(xlDown).Offset(-1,0).Row 会漏掉最后一行数据，应该用Range("A" & Rows.Count).End(xlUp).Row获取有效数据行尾。
2. Goto语句导致索引异常：匹配跳转后，q/n超出循环范围，导致高亮操作指向错误单元格。
3. 变量未初始化：dif1/dif3未初始化为0，可能导致复制位置错乱。
4. 复制范围错误：第二个循环中复制Cells(n,4)区域，但n此时已超出列表1行范围，应使用Cells(m,4)。
5. 高亮逻辑混乱：高亮操作位置错误，未在匹配时直接处理对应行。

修正后的代码 #

Sub CompareTwoColumns_Fixed()
    Dim wsSource As Worksheet
    Dim lr1 As Long, lr2 As Long
    Dim r As Long, q As Long
    Dim dif1 As Long, dif2 As Long
    Dim isMatch As Boolean
    
    ' 绑定源工作表，避免切换激活表出错
    Set wsSource = ThisWorkbook.Sheets(1)
    ' 初始化复制位置计数器
    dif1 = 1
    dif2 = 1
    
    ' 正确获取两列表最后一行
    lr1 = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
    lr2 = wsSource.Range("D" & wsSource.Rows.Count).End(xlUp).Row
    
    ' 处理列表1：找独有项+高亮匹配项
    For r = 3 To lr1
        isMatch = False
        ' 遍历列表2找匹配
        For q = 3 To lr2
            If wsSource.Cells(r, 1).Value = wsSource.Cells(q, 4).Value Then
                isMatch = True
                ' 高亮列表1匹配行（A、B列）
                wsSource.Range(wsSource.Cells(r, 1), wsSource.Cells(r, 2)).Interior.Color = vbYellow
                ' 高亮列表2匹配行（D、E列）
                wsSource.Range(wsSource.Cells(q, 4), wsSource.Cells(q, 5)).Interior.Color = vbYellow
                Exit For ' 找到匹配即退出内层循环
            End If
        Next q
        
        ' 无匹配则复制到Sheet3（列表1独有）
        If Not isMatch Then
            wsSource.Range(wsSource.Cells(r, 1), wsSource.Cells(r, 2)).Copy
            ThisWorkbook.Sheets(3).Cells(dif2, 1).PasteSpecial Paste:=xlPasteValues
            dif2 = dif2 + 1
        End If
    Next r
    
    ' 处理列表2：找独有项（跳过已高亮的匹配项）
    For q = 3 To lr2
        If wsSource.Cells(q, 4).Interior.Color <> vbYellow Then
            ' 复制到Sheet2（列表2独有）
            wsSource.Range(wsSource.Cells(q, 4), wsSource.Cells(q, 5)).Copy
            ThisWorkbook.Sheets(2).Cells(dif1, 1).PasteSpecial Paste:=xlPasteValues
            dif1 = dif1 + 1
        End If
    Next q
    
    ' 清除剪贴板
    Application.CutCopyMode = False
End Sub

修正要点 #

• 改用Rows.Count.End(xlUp)准确获取数据行尾，避免遗漏
• 用isMatch标记替代Goto语句，避免索引越界
• 明确绑定工作表，防止因激活表变化出错
• 初始化计数器，确保复制从第一行开始
• 匹配时直接高亮对应行，逻辑清晰
• 处理列表2独有项时，通过高亮状态跳过已匹配项，无需重复遍历

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