VBA对比Sheet1与Sheet2数据差异并输出至Sheet3问题求助

原代码核心问题 #

• 首个行列循环版本：调用Find方法成功匹配到Sheet1的对应标识符行后，没有使用返回的Range对象的行号取值，仍然用Sheet2的行号i读取Sheet1的单元格，两表行数不一致时必然取错值
• 三层循环版本：新增的Sheet1遍历循环完全冗余，既大幅拖慢运行效率，还会导致同一标识符重复写入差异结果
• 两个版本均遗漏了仅在Sheet1存在的标识符的差异统计，只处理了Sheet2有的标识符

修复后代码 #

Sub 对比两表差异输出()
    Dim wb As Workbook
    Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet
    Dim lastrow1 As Long, lastrow2 As Long, i As Long, j As Long, k As Long
    Dim M As String, rg As Range
    Dim val1 As Double, val2 As Double
    
    Set wb = ThisWorkbook
    Set sht1 = wb.Sheets("sheet1")
    Set sht2 = wb.Sheets("sheet2")
    Set sht3 = wb.Sheets("List of Changes")
    
    ' 用Long类型避免行数超过32767时Integer溢出报错
    lastrow1 = sht1.Cells(sht1.Rows.Count, "C").End(xlUp).Row
    lastrow2 = sht2.Cells(sht2.Rows.Count, "C").End(xlUp).Row
    k = 2 ' Sheet3差异内容起始写入行
    
    ' 初始化表头，清空旧数据避免残留
    sht3.Range("M1:T1") = Array("Seq", "Grade ID", "Item", "UOM", "Issue 1", "Issue 2", "Change", "Remark")
    sht3.Range("M1:T1").Font.Bold = True
    sht3.Range("M2:T" & sht3.Rows.Count).ClearContents
    
    ' 遍历所有需要对比的列（8到27列），合并原两段重复的循环逻辑
    For j = 8 To 27
        ' 遍历Sheet2所有行，统计Sheet2存在的标识符差异
        For i = 2 To lastrow2
            val2 = sht2.Cells(i, j).Value
            ' 全值匹配Sheet1中的对应标识符行，避免模糊匹配错误
            Set rg = sht1.Range("E2:E" & lastrow1).Find(What:=sht2.Range("E" & i).Value, LookIn:=xlValues, LookAt:=xlWhole)
            
            ' 匹配不到则Sheet1值按0计算，匹配到则取对应行的值
            val1 = IIf(rg Is Nothing, 0, sht1.Cells(rg.Row, j).Value)
            
            ' 数值不同才写入差异表
            If val1 <> val2 Then
                sht3.Range("N" & k).Value = sht2.Cells(i, 5).Value
                M = sht2.Cells(1, j).Value
                ' 按列区间区分UOM截取长度
                sht3.Range("P" & k).Value = IIf(j <= 17, Right(M, 3), Right(M, 2))
                sht3.Range("O" & k).Value = Left(M, 10)
                sht3.Range("Q" & k).Value = val1
                sht3.Range("R" & k).Value = val2
                sht3.Range("S" & k).Value = val2 - val1
                ' 保留原逻辑行号每次+2的规则
                k = k + 2
            End If
        Next i
    Next j
    
    ' 补充统计仅在Sheet1存在的标识符差异
    For j = 8 To 27
        For i = 2 To lastrow1
            Set rg = sht2.Range("E2:E" & lastrow2).Find(What:=sht1.Range("E" & i).Value, LookIn:=xlValues, LookAt:=xlWhole)
            If rg Is Nothing Then
                val1 = sht1.Cells(i, j).Value
                val2 = 0
                If val1 <> 0 Then
                    sht3.Range("N" & k).Value = sht1.Cells(i, 5).Value
                    M = sht1.Cells(1, j).Value
                    sht3.Range("P" & k).Value = IIf(j <= 17, Right(M, 3), Right(M, 2))
                    sht3.Range("O" & k).Value = Left(M, 10)
                    sht3.Range("Q" & k).Value = val1
                    sht3.Range("R" & k).Value = val2
                    sht3.Range("S" & k).Value = val2 - val1
                    k = k + 2
                End If
            End If
        Next i
    Next j
End Sub

优化说明 #

• 直接使用Find返回的匹配行号取值，彻底解决两表行数不匹配取错值的问题
• 合并重复代码，可维护性大幅提升，运行效率比三层循环版本提升数倍
• 补充了仅在Sheet1存在的标识符的差异统计，完全符合需求中“单侧缺失按0计算”的规则
• 增加全值匹配限制，避免模糊匹配导致的匹配错误
• 增加旧数据清空逻辑，避免历史数据干扰新的对比结果

内容的提问来源于stack exchange，提问作者chan hong chon