Question

我创建了一个宏，它将Workbook1的所有工作表与Workbook2的工作表进行比较，并突出显示第三个工作簿中的差异（逐页）

我已将差异分类为不同的标题，如： -

列表

输入值已更改.-文字当值/文字被文字/值替换时

值不匹配值替换为错误值

文字不匹配由不正确的文字替换的值

不正确的公式公式被不同的公式

替换

公式已删除公式已删除

已嵌入公式已添加公式

已删除的值缺少值

增值新增值

现在我的问题是当前，在比较两个工作簿时，如果从任何工作簿2中删除了任何值，那么在将其与Workbook1进行比较时，它将在＆＃34;输入值更改下进行分类.-文本＆＃34;但是我希望它能够被删除＆＃34; Value Deleted＆＃34;

，第二个问题是目前，在比较两个工作簿时，如果从任何工作簿2中添加了任何值，那么在将其与Workbook1进行比较时，它将在＆＃34;输入值更改下进行分类.-文本＆＃34;但我希望它能够进入＆＃34;增值＆＃34;

我想以下两行需要修改：

If TypeName(R2.Value) = "" Then
          NoteError R1.Address, "Value Deleted", R1.Value, "**Missing Value**"

         If TypeName(R1.Value) = "" Then
          NoteError R1.Address, "Value Added", "**Missing Value**", R2.Value

整体守则： -

Sub ExCompare()
  Dim WS As Worksheet
  Workbooks.Add
  For Each WS In Workbooks("Solution_Project.xlsx").Worksheets
    Call CompareWorkbooks(WS, Workbooks("Template_Project .xlsx").Worksheets(WS.Name))
  Next
End Sub

Sub CompareWorkbooks(ByVal WS1 As Worksheet, ByVal WS2 As Worksheet)
Dim iRow As Integer
Dim iCol As Integer
Dim R1 As Range
Dim R2 As Range

  Worksheets.Add.Name = WS1.Name ' new book for the results
  Range("A1:D1").Value = Array("Address", "Difference", WS1.Parent.Name, WS2.Parent.Name)
  Range("A2").Select
  For iRow = 1 To Application.Max(WS1.Range("A1").SpecialCells(xlLastCell).Row, _
                      WS2.Range("A1").SpecialCells(xlLastCell).Row)
    For iCol = 1 To Application.Max(WS1.Range("A1").SpecialCells(xlLastCell).Column, _
                      WS2.Range("A1").SpecialCells(xlLastCell).Column)

      Set R1 = WS1.Cells(iRow, iCol)
      Set R2 = WS2.Cells(iRow, iCol)

      ' compare the types to avoid getting VBA type mismatch errors.
      If TypeName(R1.Value) <> TypeName(R2.Value) Then
        NoteError R1.Address, "Entered Value Changed.- Text", R1.Value, R2.Value
      ElseIf R1.Value <> R2.Value Then
        If TypeName(R1.Value) = "Double" Then
          If Abs(R1.Value - R2.Value) > R1.Value * 10 ^ (-12) Then
            NoteError R1.Address, "Value Mismatch", R1.Value, R2.Value
          End If
        Else
            NoteError R1.Address, "Text Mismatch", R1.Value, R2.Value
        End If
        If TypeName(R2.Value) = "" Then
          NoteError R1.Address, "Value Deleted", R1.Value, "**Missing Value**"
        End If
         If TypeName(R1.Value) = "" Then
          NoteError R1.Address, "Value Added", "**Missing Value**", R2.Value
        End If
      End If

      ' record formula without leading "=" to avoid them being evaluated
      If R1.HasFormula Then
        If R2.HasFormula Then
          If R1.Formula <> R2.Formula Then
            NoteError R1.Address, "Incorrect Formula", Mid(R1.Formula, 2), Mid(R2.Formula, 2)
          End If
        Else
          NoteError R1.Address, "Formula Deleted", Mid(R1.Formula, 2), "**no formula**"
        End If
      Else
        If R2.HasFormula Then
          NoteError R1.Address, "Formula Embedded", "**no formula**", Mid(R2.Formula, 2)
        End If
      End If
      If R1.NumberFormat <> R2.NumberFormat Then
        NoteError R1.Address, "NumberFormat", R1.NumberFormat, R2.NumberFormat
      End If
    Next iCol
  Next iRow
  With ActiveSheet.UsedRange.Columns
    .AutoFit
    .HorizontalAlignment = xlLeft
  End With
End Sub

Sub NoteError(Address As String, What As String, V1, V2)
  ActiveCell.Resize(1, 4).Value = Array(Address, What, V1, V2)
  ActiveCell.Offset(1, 0).Select
  If ActiveCell.Row = Rows.Count Then
    MsgBox "Too many differences", vbExclamation
    End
  End If
End Sub

比较两个工作簿并突出显示第三个工作簿中的差异

0 个答案: