Excel VBA比对单元格后复制内容异常：代码仅运行至第60行

原代码核心问题 #

1. 工作表引用模糊：代码中Cells未指定所属工作表，默认使用当前活动工作表，若活动表不是04_2023，Cells(Rows.Count,1).End(xlUp)会错误读取其他表的A列最后行号，导致遍历提前终止在第60行。
2. 匹配逻辑错误：直接按行号比对两表的B、G列，默认两行表的行完全一一对应，但实际新增行后行号不匹配，会漏匹配或匹配错误。

基础修正代码（适配行号不对应场景） #

Sub CopyComments()
    Dim wsNew As Worksheet, wsOld As Worksheet
    Dim lastRowNew As Long, lastRowOld As Long
    Dim i As Long, j As Long
    
    ' 明确绑定工作表对象，避免活动表干扰
    Set wsNew = ThisWorkbook.Sheets("04_2023")
    Set wsOld = ThisWorkbook.Sheets("Kreuztabelle")
    
    ' 基于B列获取两表有效数据的最后行（B列是比对核心列）
    lastRowNew = wsNew.Cells(wsNew.Rows.Count, "B").End(xlUp).Row
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "B").End(xlUp).Row
    
    ' 遍历新表每一行，在旧表中查找匹配项
    For i = 2 To lastRowNew
        For j = 2 To lastRowOld
            ' 比对B、G列内容是否一致
            If wsOld.Cells(j, "B").Value = wsNew.Cells(i, "B").Value And _
               wsOld.Cells(j, "G").Value = wsNew.Cells(i, "G").Value Then
                ' 复制Q、R列内容到新表对应行
                wsOld.Cells(j, "Q").Copy Destination:=wsNew.Cells(i, "Q")
                wsOld.Cells(j, "R").Copy Destination:=wsNew.Cells(i, "R")
                Exit For ' 找到匹配后退出内层循环，提升效率
            End If
        Next j
    Next i
End Sub

高效优化版（适合大数据量） #

如果两表数据行数较多，用字典存储旧表匹配关系可以避免双层循环，大幅提升速度：

Sub CopyCommentsFast()
    Dim wsNew As Worksheet, wsOld As Worksheet
    Dim lastRowNew As Long, lastRowOld As Long
    Dim i As Long
    Dim matchDict As Object
    
    Set wsNew = ThisWorkbook.Sheets("04_2023")
    Set wsOld = ThisWorkbook.Sheets("Kreuztabelle")
    Set matchDict = CreateObject("Scripting.Dictionary")
    
    lastRowOld = wsOld.Cells(wsOld.Rows.Count, "B").End(xlUp).Row
    
    ' 将旧表的B+G组合作为唯一键，Q、R值存入字典
    For i = 2 To lastRowOld
        Dim key As String
        key = wsOld.Cells(i, "B").Value & "|" & wsOld.Cells(i, "G").Value
        If Not matchDict.Exists(key) Then
            matchDict(key) = Array(wsOld.Cells(i, "Q").Value, wsOld.Cells(i, "R").Value)
        End If
    Next i
    
    lastRowNew = wsNew.Cells(wsNew.Rows.Count, "B").End(xlUp).Row
    
    ' 遍历新表，通过字典快速匹配并赋值
    For i = 2 To lastRowNew
        key = wsNew.Cells(i, "B").Value & "|" & wsNew.Cells(i, "G").Value
        If matchDict.Exists(key) Then
            wsNew.Cells(i, "Q").Value = matchDict(key)(0)
            wsNew.Cells(i, "R").Value = matchDict(key)(1)
        End If
    Next i
End Sub

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