如何快速比较两个工作薄的不同

Mengkelyu

工作中因为要试图和老板解释数字变化，所以想找有没有什么方法可以很快找出两个excel的不同。

感谢Excel Macro Class
的这个代码可以用黄色高亮两个Excel不一致的地方

  Sub CompareTwoWorkbooks()
 
  Dim wb1 As Workbook, wb2 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet, wsMatch As Boolean
 
  'Open a file dialog to select workbooks (optional)
 
  'Set each of the 2 workbooks to object variables
  Set wb1 = ThisWorkbook
  Set wb2 = Workbooks(2)
 
  If wb1.Worksheets.Count = wb2.Worksheets.Count Then
 
    'Loop through worksheets
    For Each ws1 In wb1.Worksheets
      wsMatch = False
      For Each ws2 In wb2.Worksheets
        If ws1.Name = ws2.Name Then
          wsMatch = True
          'Compare the 2 worksheets
          For Each cell In ws1.Range("A1").CurrentRegion
            If cell.Value <> ws2.Range(cell.Address).Value Then
                cell.Interior.Color = vbYellow
                MsgBox "Mismatch cell " & cell.Address & " in worksheet " & ws1.Name
            End If
          Next cell
          Exit For
        End If
      Next ws2
      If wsMatch = False Then ws1.Tab.Color = vbYellow
    Next ws1
  Else
    MsgBox "Worksheets mismatch"
  End If
 
  End Sub

Mengkelyu

但我想就这个代码进行如下改进：

首先这个代码所比较的范围是 Range("A1").CurrentRegion，这里选中的范围实际上是范围选中A1后按住Ctrl + A选中的范围。不一定是全部的范围
希望可以达到能够比较差值，并且留下公式的效果。

Mengkelyu

最终代码和文件如下，有时间大家感兴趣的话来解释

Sub CompareTwoWorkbooks()
 Application.ScreenUpdating = False
 Application.Calculation = xlCalculationManual
 
  Dim wb1 As Workbook, wb2 As Workbook, wbresult As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet, wsMatch As Boolean
  
  Dim files1 As String, files2 As String
  
  files1 = Range("files1").Value
  files2 = Range("files2").Value
 
  'Open a file dialog to select workbooks (optional)
 Set wbresult = Workbooks.Add(files1)
  'Set each of the 2 workbooks to object variables
  Set wb1 = Workbooks.Open(Filename:=files1, UpdateLinks:=0, ReadOnly:=True)
  Set wb2 = Workbooks.Open(Filename:=files2, UpdateLinks:=0, ReadOnly:=True)

    'Loop through worksheets
    For Each ws1 In wb1.Worksheets
     Debug.Print ws1.Name
      wsMatch = False
      For Each ws2 In wb2.Worksheets
        If ws1.Name = ws2.Name Then
          wsMatch = True
          'Compare the 2 worksheets
          For Each cell In ws1.UsedRange
            If IsNumeric(cell.Value) = True And cell.Value <> "" Then
                wbresult.Worksheets(ws2.Name).Range(cell.Address).Formula = "=" & cell.Address(External:=True, RowAbsolute:=False, ColumnAbsolute:=False) & "-" & ws2.Range(cell.Address).Address(External:=True, RowAbsolute:=False, ColumnAbsolute:=False)
            End If
          Next cell
          Exit For
        End If
      Next ws2
      If wsMatch = False Then wbresult.Worksheets(ws1.Name).Tab.Color = vbYellow
    Next ws1

 wb1.Close savechanges:=False
 wb2.Close savechanges:=False
 
 Application.ScreenUpdating = True
 Application.Calculate
  Application.Calculation = xlCalculationAutomatic
  End Sub

Tool For Checking.zip

Mengkelyu

@Mengkelyu

注意到这个代码在工作簿中有公式或数字错误时会报 "type Mismatch"的错误。
可以在代码开头加入

On Error Resume Next

来跳过这些错误，继续运行代码。