VBA匹配两工作表不同行索引行时差异行不显示到Sheet4求助

• 读取Sheet1、Sheet2数据范围的逻辑不合理：你用H列的最后一行作为整表的截止行，一旦H列存在空值、或者其他列行数比H列多，会导致读入的a、b数组不完整，漏处理尾部行，这也是你只有首行匹配时输出才正常的核心原因。
• 差异行覆盖不全：当前逻辑仅将「Sheet1中匹配到key但H列不等」的行写入Sheet4，完全遗漏了「Sheet2中存在但Sheet1中找不到对应key」的行，这部分也属于差异数据。
• 字典覆盖问题：如果Sheet2存在多组C/D/E/I列完全相同的重复行，字典只会保留最后一行的索引，前面的重复行不会参与匹配。
• 差异数组容量不足：你初始化d数组时仅按Sheet1的行数定义，如果Sheet2行数多于Sheet1，要写入Sheet2独有行时会出现下标越界。
• 写入目标表时未清空旧数据：多次运行代码会在Sheet3、Sheet4原有数据后追加新内容，不会覆盖旧结果，容易混淆。

Sub MatchRows()
    Dim a As Variant, b As Variant, c As Variant, d As Variant
    Dim i As Long, j As Long, k As Long, m As Long, n As Long
    Dim dic As Object, ky As String
    Dim maxRow1 As Long, maxRow2 As Long, colCnt As Long
    Dim matchFlag As Variant ' 标记Sheet2的行是否被匹配过
    
    Set dic = CreateObject("Scripting.Dictionary")
    ' 修正取数范围逻辑：用UsedRange确定有效行，避免单列取行导致的漏读
    With Sheets("Sheet1")
        maxRow1 = .UsedRange.Rows(.UsedRange.Rows.Count).Row
        If maxRow1 < 2 Then Exit Sub ' 无有效数据直接退出
        a = .Range("A2:I" & maxRow1).Value
    End With
    With Sheets("Sheet2")
        maxRow2 = .UsedRange.Rows(.UsedRange.Rows.Count).Row
        If maxRow2 < 2 Then Exit Sub
        b = .Range("A2:I" & maxRow2).Value
    End With
    colCnt = UBound(a, 2)
    ' 初始化数组容量按两个表的最大行数，避免越界
    ReDim c(1 To UBound(a, 1) + UBound(b, 1), 1 To colCnt)
    ReDim d(1 To UBound(a, 1) + UBound(b, 1), 1 To colCnt)
    ReDim matchFlag(1 To UBound(b, 1)) ' 初始化匹配标记为False
    
    ' 字典存key对应的Sheet2行号列表，解决重复key问题
    For i = 1 To UBound(b, 1)
        ky = b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 9)
        If Not dic.exists(ky) Then
            Set dic(ky) = CreateObject("System.Collections.ArrayList")
        End If
        dic(ky).Add i
    Next

    ' 先处理Sheet1的所有行
    For i = 1 To UBound(a, 1)
        ky = a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 9)
        If dic.exists(ky) Then
            ' 遍历相同key的所有Sheet2行，找到未匹配的
            For Each j In dic(ky)
                If matchFlag(j) = False Then
                    matchFlag(j) = True ' 标记为已匹配
                    If a(i, 8) = b(j, 8) Then
                        ' 匹配成功写入Sheet3数组
                        k = k + 1
                        For n = 1 To colCnt
                            c(k, n) = a(i, n)
                        Next
                        c(k, 8) = 0
                    Else
                        ' H列不等写入差异数组
                        m = m + 1
                        For n = 1 To colCnt
                            d(m, n) = a(i, n)
                        Next
                        d(m, 8) = a(i, 8) - b(j, 8)
                    End If
                    Exit For
                End If
            Next
        Else
            ' Sheet1独有行写入差异
            m = m + 1
            For n = 1 To colCnt
                d(m, n) = a(i, n)
            Next
            d(m, 8) = "Sheet1独有"
        End If
    Next
    
    ' 处理Sheet2中未被匹配的独有行
    For j = 1 To UBound(b, 1)
        If matchFlag(j) = False Then
            m = m + 1
            For n = 1 To colCnt
                d(m, n) = b(j, n)
            Next
            d(m, 8) = "Sheet2独有"
        End If
    Next

    ' 写入前清空目标表旧数据，从第二行开始写（保留表头）
    Sheets("Sheet3").Range("A2:I" & Sheets("Sheet3").Rows.Count).ClearContents
    Sheets("Sheet4").Range("A2:I" & Sheets("Sheet4").Rows.Count).ClearContents
    If k > 0 Then Sheets("Sheet3").Range("A2").Resize(k, colCnt).Value = c
    If m > 0 Then Sheets("Sheet4").Range("A2").Resize(m, colCnt).Value = d

    Set dic = Nothing
End Sub

• 调整了数据源读取逻辑，用工作表已用范围确定截止行，不会因为某列有空值漏读数据
• 补充了Sheet2独有行的判断，所有差异行都会写入Sheet4
• 用ArrayList存储相同key的所有Sheet2行索引，解决重复key的覆盖问题
• 扩大了数组初始化容量，避免下标越界
• 写入前自动清空目标表旧数据，避免多次运行结果混淆

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