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



  • 工作中因为要试图和老板解释数字变化,所以想找有没有什么方法可以很快找出两个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
     
    
    


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

    1. 首先这个代码所比较的范围是 Range("A1").CurrentRegion,这里选中的范围实际上是范围选中A1后按住Ctrl + A选中的范围。不一定是全部的范围

    2. 希望可以达到能够比较差值,并且留下公式的效果。



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

    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


Log in to reply