如何优化VBA对比Excel文档脚本，实现重复差异项汇总统计？

我完全懂你的痛点——那些反复出现的预期差异占满了输出结果，真正需要关注的意外错误反而被淹没了。咱们可以通过引入字典（Dictionary）来统计每种差异的出现次数，把重复的差异合并展示，这样一眼就能看出哪些是高频的预期问题，哪些是罕见的意外错误。

下面是修改后的完整脚本，我已经加上了详细注释，你只需要替换掉那些[User]、[Path]这类占位符就行：

Option Compare Text
Sub CompareWorkbooksWithSummary()
    Dim varSheetA As Variant
    Dim varSheetB As Variant
    Dim strRangeToCheck As String
    Dim iRow As Long, iCol As Long
    Dim diffDict As Object ' 用来存储差异类型和出现次数的字典
    Dim diffKey As String ' 唯一标识一种差异的键
    Dim outputRow As Long ' 输出到新文档的行号
    
    ' 初始化字典
    Set diffDict = CreateObject("Scripting.Dictionary")
    outputRow = 1
    
    ' 打开需要对比的工作簿（替换成你的实际路径和文件名）
    Dim wbkA As Workbook, wbkB As Workbook, wbkC As Workbook
    Set wbkA = Workbooks.Open(Filename:="C:\Users\[User]\[Path]\[WorkbookA].xlsm")
    Set wbkB = Workbooks.Open(Filename:="C:\Users\[User]\[Path]\[WorkbookB].xlsm")
    Set wbkC = Workbooks.Open(Filename:="C:\Users\[User]\[Path]\New.xlsm") ' 输出结果的工作簿
    
    ' 设置要对比的范围（根据你的实际数据调整）
    strRangeToCheck = "A2:BX2000"
    varSheetA = wbkA.Worksheets("[WorksheetName]").Range(strRangeToCheck)
    varSheetB = wbkB.Worksheets("Sheet1").Range(strRangeToCheck)
    
    ' 遍历所有单元格找差异
    For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
        For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
            If varSheetA(iRow, iCol) <> varSheetB(iRow, iCol) Then
                ' 构建唯一差异键：ID + 列名 + A值 + B值
                ' 这里用Cells(1,iCol)获取列标题，方便识别差异所在列
                diffKey = varSheetA(iRow, 1) & "|" & _
                          wbkA.Worksheets("[WorksheetName]").Cells(1, iCol).Value & "|" & _
                          varSheetA(iRow, iCol) & "|" & _
                          varSheetB(iRow, iCol)
                
                ' 如果字典里已有这个差异，次数+1；否则新增记录
                If diffDict.Exists(diffKey) Then
                    diffDict(diffKey) = diffDict(diffKey) + 1
                Else
                    diffDict(diffKey) = 1
                End If
            End If
        Next iCol
    Next iRow
    
    ' 把汇总结果输出到新工作簿
    With wbkC.Worksheets("Sheet1") ' 替换成你要输出的工作表
        ' 先写表头
        .Cells(outputRow, 1) = "ID"
        .Cells(outputRow, 2) = "差异列"
        .Cells(outputRow, 3) = "工作簿A值"
        .Cells(outputRow, 4) = "工作簿B值"
        .Cells(outputRow, 5) = "出现次数"
        outputRow = outputRow + 1
        
        ' 遍历字典输出每一种差异
        For Each diffKey In diffDict.Keys
            ' 拆分差异键，提取各个字段
            Dim keyParts As Variant
            keyParts = Split(diffKey, "|")
            
            .Cells(outputRow, 1) = keyParts(0)
            .Cells(outputRow, 2) = keyParts(1)
            .Cells(outputRow, 3) = keyParts(2)
            .Cells(outputRow, 4) = keyParts(3)
            .Cells(outputRow, 5) = diffDict(diffKey)
            
            outputRow = outputRow + 1
        Next diffKey
        
        ' 自动调整列宽
        .Columns("A:E").AutoFit
    End With
    
    ' 关闭源工作簿（如果不需要保留打开状态的话）
    wbkA.Close SaveChanges:=False
    wbkB.Close SaveChanges:=False
    
    MsgBox "差异汇总完成！", vbInformation
End Sub

关键优化点说明： #

• 字典统计：用Scripting.Dictionary来记录每种差异的出现次数，避免重复输出相同差异
• 唯一差异键：通过ID+列标题+A值+B值的组合来唯一标识一种差异，确保不会把不同场景的差异混为一谈
• 汇总输出：最后把所有差异类型集中输出，高频的预期差异会清晰展示，意外错误一眼就能找到
• 友好表头：新增了“差异列”和“出现次数”列，让输出结果的可读性大幅提升

如果需要按出现次数排序差异结果，可以在输出前对字典的项进行排序，有需要的话我可以再补充这部分代码～

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