调整VBA工作簿对比宏：仅报告真实差异，消除行插入误报

问题背景 #

我正在开展迭代构建物理数据模型的项目，每月会生成包含多工作表的新版工作簿，期间会插入新行或修改文本字段。原有的VBA宏通过行号遍历对比新旧工作簿，但当新工作簿插入新行后，后续所有行因行号偏移被误报为差异，即便内容无实际变更，需要修改宏以仅报告真实存在的差异行。

修改后的VBA代码 #

Public Sub CompareTwoWorkbooks()
    Dim wsExisting As Worksheet
    Dim wsNew As Worksheet
    Dim resultWB As Workbook
    
    Set resultWB = Workbooks.Add
    
    ' 遍历现有工作簿的所有工作表，匹配新工作簿的同名工作表
    For Each wsExisting In Workbooks("D365 Fields Physical Data Model - Existing.xlsm").Worksheets
        On Error Resume Next
        Set wsNew = Workbooks("D365 Fields Physical Data Model - New.xlsm").Worksheets(wsExisting.Name)
        On Error GoTo 0
        
        If Not wsNew Is Nothing Then
            Call CompareWorksheets(wsExisting, wsNew, resultWB)
            Set wsNew = Nothing
        End If
    Next wsExisting
End Sub

Public Sub CompareWorksheets(ByVal ws1 As Worksheet, ByVal ws2 As Worksheet, ByVal resultWB As Workbook)
    Dim wsResult As Worksheet
    Dim dictRowMap As Object ' 存储现有表主键到行号的映射
    Dim keyCol As Integer ' 主键列，假设为A列，可根据实际调整
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long, k As Long
    Dim currentKey As String
    Dim r1 As Range, r2 As Range
    Dim lastCol1 As Long, lastCol2 As Long
    Dim maxCol As Long
    
    ' 设置主键列（这里假设A列为唯一标识符，可根据实际修改）
    keyCol = 1
    
    ' 创建结果工作表
    Set wsResult = resultWB.Worksheets.Add
    wsResult.Name = ws1.Name
    wsResult.Range("A1:D1").Value = Array("地址/状态", "差异类型", ws1.Parent.Name, ws2.Parent.Name)
    
    ' 初始化字典，存储现有表的主键与行号映射
    Set dictRowMap = CreateObject("Scripting.Dictionary")
    lastRow1 = ws1.Cells(ws1.Rows.Count, keyCol).End(xlUp).Row
    
    ' 加载现有表的主键数据
    For i = 2 To lastRow1 ' 假设第一行是表头
        currentKey = Trim(ws1.Cells(i, keyCol).Value)
        If currentKey <> "" And Not dictRowMap.Exists(currentKey) Then
            dictRowMap.Add currentKey, i
        End If
    Next i
    
    ' 处理新表的行：匹配现有表的主键，对比差异
    lastRow2 = ws2.Cells(ws2.Rows.Count, keyCol).End(xlUp).Row
    lastCol1 = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
    lastCol2 = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
    maxCol = Application.Max(lastCol1, lastCol2)
    
    For i = 2 To lastRow2
        currentKey = Trim(ws2.Cells(i, keyCol).Value)
        If currentKey <> "" Then
            If dictRowMap.Exists(currentKey) Then
                ' 匹配到现有行，对比各列内容
                j = dictRowMap(currentKey)
                For k = 1 To maxCol
                    Set r1 = ws1.Cells(j, k)
                    Set r2 = ws2.Cells(i, k)
                    Call CompareCell(r1, r2, wsResult)
                Next k
                ' 标记已匹配的行，后续检测删除行
                dictRowMap.Remove currentKey
            Else
                ' 新表中存在的主键，现有表没有：记录为新增行
                Call LogDifference(wsResult, "新增行: 行" & i, "新增", "", ws2.Cells(i, keyCol).Value)
            End If
        End If
    Next i
    
    ' 处理现有表中未匹配的行：记录为删除行
    For Each currentKey In dictRowMap.Keys
        j = dictRowMap(currentKey)
        Call LogDifference(wsResult, "删除行: 行" & j, "删除", ws1.Cells(j, keyCol).Value, "")
    Next currentKey
    
    ' 格式化结果表
    With wsResult.UsedRange.Columns
        .AutoFit
        .HorizontalAlignment = xlLeft
    End With
End Sub

Private Sub CompareCell(ByVal r1 As Range, ByVal r2 As Range, ByVal wsResult As Worksheet)
    ' 对比单元格类型
    If TypeName(r1.Value) <> TypeName(r2.Value) Then
        Call LogDifference(wsResult, r1.Address, "类型差异", r1.Value, r2.Value)
        Exit Sub
    End If
    
    ' 对比单元格值（数值类型做精度判断）
    If TypeName(r1.Value) = "Double" Then
        If Abs(r1.Value - r2.Value) > r1.Value * 10 ^ (-12) Then
            Call LogDifference(wsResult, r1.Address, "数值差异", r1.Value, r2.Value)
        End If
    Else
        If r1.Value <> r2.Value Then
            Call LogDifference(wsResult, r1.Address, "内容差异", r1.Value, r2.Value)
        End If
    End If
    
    ' 对比公式
    If r1.HasFormula <> r2.HasFormula Then
        If r1.HasFormula Then
            Call LogDifference(wsResult, r1.Address, "公式差异", Mid(r1.Formula, 2), "无公式")
        Else
            Call LogDifference(wsResult, r1.Address, "公式差异", "无公式", Mid(r2.Formula, 2))
        End If
    ElseIf r1.HasFormula Then
        If r1.Formula <> r2.Formula Then
            Call LogDifference(wsResult, r1.Address, "公式内容差异", Mid(r1.Formula, 2), Mid(r2.Formula, 2))
        End If
    End If
    
    ' 对比数字格式
    If r1.NumberFormat <> r2.NumberFormat Then
        Call LogDifference(wsResult, r1.Address, "格式差异", r1.NumberFormat, r2.NumberFormat)
    End If
End Sub

Private Sub LogDifference(ByVal wsResult As Worksheet, ByVal address As String, ByVal diffType As String, ByVal val1 As Variant, ByVal val2 As Variant)
    Dim lastResultRow As Long
    lastResultRow = wsResult.Cells(wsResult.Rows.Count, 1).End(xlUp).Row + 1
    
    If lastResultRow > wsResult.Rows.Count Then
        MsgBox "差异数量过多，超出工作表行限制", vbExclamation
        Exit Sub
    End If
    
    wsResult.Cells(lastResultRow, 1).Value = address
    wsResult.Cells(lastResultRow, 2).Value = diffType
    wsResult.Cells(lastResultRow, 3).Value = val1
    wsResult.Cells(lastResultRow, 4).Value = val2
End Sub

关键改动说明 #

• 基于主键匹配行：不再按行号硬遍历，而是通过工作表中的唯一主键列（默认A列，可自行调整keyCol变量）建立新旧行的映射关系，避免插入新行导致的行号偏移误报。
• 新增行/删除行检测：自动识别新表中新增的行、旧表中被删除的行，并单独记录状态。
• 模块化拆分：将单元格对比逻辑拆分为独立的CompareCell过程，代码更清晰易维护。
• 避免Active对象依赖：修改LogDifference过程，直接操作结果工作表，减少Select等易出错的Active对象调用。

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