突出显示跨工作簿范围 VBA 的差异

Question

我设法将一个工作簿上的 3 个单独范围与 3 个工作簿中的 3 个单个范围进行了比较。现在它被写入只是弹出一个消息框，让我知道数据相同或数据不同。我想做的是让宏不仅让我知道存在差异，而且还要突出差异对我的影响。我想这可以通过突出显示第一个工作簿上与其他三个不同的单元格来完成，或者我想这也可以通过从 COL N 开始粘贴相关工作表上的不同值来完成。

Sub Macro1()

Dim varDataMatrix() As Variant
Dim varDataMatrix2() As Variant 
Dim varDataMatrix3() As Variant 
Dim lngArrayCount As Long
Dim lngArrayCount2 As Long
Dim lngArrayCount3 As Long
Dim rngMyCell As Range
Dim rngMyCell2 As Range
Dim rngMyCell3 As Range
Dim wbWorkbookOne As Workbook
Dim wbWorkbookTwo As Workbook
Dim wbWorkbookThree As Workbook
Dim wbWorkbookFour As Workbook

Application.ScreenUpdating = False

Set wbWorkbookOne = Workbooks("PositionTest.xls") 
Set wbWorkbookTwo = Workbooks("ATest.xlsx") 
Set wbWorkbookThree = Workbooks("BTest.xlsx") 
Set wbWorkbookFour = Workbooks("CTest.xlsx") 

'First create an array of the values in the desired range of the first workbook.
For Each rngMyCell In wbWorkbookOne.Sheets("Positions").Range("B3:B6") 
    lngArrayCount = lngArrayCount + 1
    ReDim Preserve varDataMatrix(1 To lngArrayCount) 
    varDataMatrix(lngArrayCount) = rngMyCell
Next rngMyCell

lngArrayCount = 0 'Initialise variable

'Loop through Array elements
For Each rngMyCell In wbWorkbookTwo.Sheets("A").Range("B2:B5")
    lngArrayCount = lngArrayCount + 1
    If rngMyCell.Value <> varDataMatrix(lngArrayCount) Then
       GoTo QuitRoutinue
    End If
Next rngMyCell


For Each rngMyCell2 In wbWorkbookOne.Sheets("Positions").Range("F3:F6") 
    lngArrayCount2 = lngArrayCount2 + 1
    ReDim Preserve varDataMatrix2(1 To lngArrayCount2) 
    varDataMatrix2(lngArrayCount2) = rngMyCell2
Next rngMyCell2

lngArrayCount2 = 0 'Initialise variable


'Loop through Array elements
For Each rngMyCell2 In wbWorkbookThree.Sheets("B").Range("B2:B5") 
    lngArrayCount2 = lngArrayCount2 + 1
    If rngMyCell2.Value <> varDataMatrix2(lngArrayCount2) Then
       GoTo QuitRoutinue
    End If
Next rngMyCell2


For Each rngMyCell3 In wbWorkbookOne.Sheets("Positions").Range("J3:J6") 
    lngArrayCount3 = lngArrayCount3 + 1
    ReDim Preserve varDataMatrix3(1 To lngArrayCount3) 'Append the record to the existing array
    varDataMatrix3(lngArrayCount3) = rngMyCell3
Next rngMyCell3

lngArrayCount3 = 0 'Initialise variable



For Each rngMyCell3 In wbWorkbookFour.Sheets("C").Range("B2:B5") 'Workbook one range is A10:A15 on 'Sheet2'.
    lngArrayCount3 = lngArrayCount3 + 1
    If rngMyCell3.Value <> varDataMatrix3(lngArrayCount3) Then
       GoTo QuitRoutinue
    End If
Next rngMyCell3


'If we get here both datasets have matched.
Set wbWorkbookOne = Nothing
Set wbWorkbookTwo = Nothing
Application.ScreenUpdating = True
Erase varDataMatrix() 'Deletes the varible contents, free some memory
MsgBox "Data is the same.", vbInformation
Exit Sub



Set wbWorkbookOne = Nothing
Set wbWorkbookTwo = Nothing
Application.ScreenUpdating = True
Erase varDataMatrix() 'Deletes the varible contents, free some memory
MsgBox "Data is different.", vbExclamation

结束子

Answer 1

突出显示位置表上的差异并显示 L 到 N 列中的值。使用 Application.Transpose 从垂直范围的单元格创建一维数组。注意：转置不适用于非连续范围。

Option Explicit

Sub Macro2()

    Dim ws(3) As Worksheet, sht, w, n As Long
    sht = Array("Positions", "A", "B", "C")
    
    For Each w In Array("PositionTest.xls", "ATest.xlsx", "BTest.xlsx", "CTest.xlsx")
        Set ws(n) = Workbooks(w).Sheets(sht(n))
        n = n + 1
    Next
    
    Dim i As Long, r As Long, diff As Long
    Dim rng0 As Range, rngN As Range, a As Range, b As Range
    Dim ar0, arN
    ' compare sheets
    For n = 1 To 3
         Set rng0 = ws(0).Range("H5:H7,H9:H11,H13:H19,H21:H22").Offset(, (n - 1) * 4) ' H, L, P
         Set rngN = ws(n).Range("E3:E18") ' sheet A, B, C
         ' copy to array
         arN = Application.Transpose(rngN)
    
         i = 0
         For Each a In rng0
             i = i + 1
             r = a.Row
             
             ' cells on position sheet
             Set b = ws(0).Cells(r, "R").Offset(, n) ' diff in col L,M,N
             
             ' compare arrays
             If a.Value <> arN(i) Then
                 a.Interior.Color = RGB(255, 255, 0) ' yellow
                 b.Value = rngN.Cells(i, 1)
                 diff = diff + 1
             Else
                 a.Interior.Pattern = False
                 b.Clear
             End If
         Next
    Next
   
    MsgBox diff & " differences", vbInformation
End Sub