Excel 比较两张图纸并仅使用唯一ID高亮显示不匹配的行

我希望匹配两个不同工作表中的行，并仅在不匹配行的第一列中高亮显示，或者更好地将不匹配行复制到新工作表中。代码应该比较两张图纸中的行，并为第二张图纸中的新行上色。Sheet2（比如2020年1月）包含的行比Sheet1（2019年12月）多，这是最近更新的工作表，它们都包含超过22k的行，并且都具有唯一ID作为第一列

我下面的代码试图突出显示所有不匹配的单元格，并且需要更长的时间来完成。我希望代码只对A列中不匹配的行（vb.Red）上色（因为它是唯一的ID），而忽略其余的列/单元格（vb.Yellow），或者如果可能，将突出显示的行复制到新的工作表中

Sub RunCompare()
Call compareSheets("Sheet1", "Sheet2") 'compareSheets("2019-01 Database", "2019-02 Database")
End Sub


Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim c As Integer, j As Integer, i As Integer, mydiffs As Integer, cnt1 As Integer, cnt2 As Integer
Dim noexist As Integer
cnt2 = Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row
cnt1 = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For i = 1 To cnt2
    For j = 1 To cnt1
        If ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, 1).Value Then
            For c = 2 To 22
                If Not ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, c).Value Then
                    ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Interior.Color = vbYellow
                    mydiffs = mydiffs + 1
                End If
            Next
        Exit For
        End If
        If j = cnt1 Then
            ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Interior.Color = vbRed
        End If
    Next
Next
'Display a message box to demonstrate the differences and if there is a new entry on the second sheet
'MsgBox mydiffs & ":differences found, " & noexist & ":no exist", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
End Sub

---

让我们简化任务，一步一步地做

• 这是两个工作表中的输入的样子：

然后，我们可以考虑阅读这些，并将它们保存到一个数组：

---

• 在两个数组中的数据之间的循环速度非常快。只有当两个数组中的两个值匹配时，才能写入第三个工作表：

---

这是第三个工作表中的结果，所有匹配值都在一行中：

整个代码是这样的：

Sub CompareTwoRanges()

    Dim rangeA As Range
    Dim rangeB As Range

    Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
    Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")

    Dim arrayA As Variant
    Dim arrayB As Variant

    With Application
        arrayA = .Transpose(.Transpose(rangeA))
        arrayB = .Transpose(.Transpose(rangeB))
    End With

    Dim myValA As Variant
    Dim myValB As Variant
    Dim currentRow As Long: currentRow = 1

    For Each myValA In arrayA
        For Each myValB In arrayB
            If myValA = myValB Then
                ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
                currentRow = currentRow + 1
            End If
        Next
    Next

End Sub

注意-如果将结果写入数组，然后从数组写入工作表，则会有另一个性能奖励。因此，写作只会发生一次。这是在数组声明之后需要在代码中实现的更改：

Dim myValA As Variant
Dim myValB As Variant
Dim resultArray() As Variant
ReDim Preserve resultArray(2 ^ 20)
Dim i As Long: i = 0

For Each myValA In arrayA
    For Each myValB In arrayB
        If myValA = myValB Then
            resultArray(i) = myValA
            i = i + 1
        End If
    Next
Next

ReDim Preserve resultArray(i)
ThisWorkbook.Worksheets(3).Cells(1, 1).Resize(UBound(resultArray)) = Application.Transpose(resultArray)

---

当您获得单元格值时，它会花费时间

因此，可以将目标范围转换为二维变量

Dim endRow AS Long
Dim olderRange AS Range
Dim olderVariant AS Variant
endRow = olderSheet.cells(rows.count,1).end(xlup).row
Set olderRange = olderSheet.Range(olderSheet.Cells(startRow, startCol), olderSheet.Cells(endRow, endCol))

'Transfer
olderVariant = olderRange 

For currentRow = 1 to UBound(olderVariant, 1)
   'Loop
   'if you want change real Cell value Or interior
   'add row Or Col weight
   if olderVariant(currentRow, currentCol) = newerVariant(currentRow, currentCol) THen
      newerSheet.Cells(currentRow+10,currentCol+10).interior.colorIndex = 3
   End if
Next currentRow

---

如果有人有同样的问题，我已经找到了一个更简单的方法。提供的表格2为对照表格：

Dim Ary1 As Variant, Ary2 As Variant
Dim r As Long

Ary1 = Sheets("Sheet1").UsedRange.Value2
Ary2 = Sheets("Sheet2").UsedRange.Value2
With CreateObject("scripting.dictionary")
   For r = 1 To UBound(Ary1)
      .Item(Ary1(r, 1)) = Empty
   Next r
   For r = 1 To UBound(Ary2)
      If Not .Exists(Ary2(r, 1)) Then Sheets("Sheet2").Cells(r, 1).Interior.Color = vbRed
   Next r
End With

---

您可以使用

COUNTIF

检查ID是否存在。如果计数返回0，则表示否，否则表示是。VBA版本是Application.WorksheetFunction.Countif我同意使用Range的想法，但我无法让你的代码正常工作。。未定义newerVariant。对不起，我的Vb技能还是很基本的@sacru2red@Abdlfatah我评论中的代码是不正确的，我不理解你的问题。我的代码只是提示snipet，它不起作用。我的问题是比较两张纸的两行，只突出显示第二张纸的第一行。例如如果工作表1的第一行和第二行分别为xx、xx1，而工作表2的第二行分别为xx、xx1、xx2，则应在工作表2中突出显示xx2，因为它实际上没有出现在工作表1中，信息不足。它们是相同的行号吗？它们是相同的字段名吗？你们能给我看看桌子吗？谢谢@vityta，看来你们搞错了。使用图形表示法时，考虑到第一张图纸的第2行包含第1行图纸2中的所有元素。然后，第3页将成为第1页的第1行，因为这是两张图纸中不匹配的行。我不想考虑表中的所有单元格，而只考虑第一个单元格（A列），因为它不会花费时间。complete@Abdlfatah-我正在解决一个更一般的问题-比较两个范围的相等值。在代码中，每个范围都显示在不同工作表上的一行中。这些范围是如何精确表示的，无论它们是列、行还是其他形式，都取决于问题的结构。

Dim endRow AS Long
Dim olderRange AS Range
Dim olderVariant AS Variant
endRow = olderSheet.cells(rows.count,1).end(xlup).row
Set olderRange = olderSheet.Range(olderSheet.Cells(startRow, startCol), olderSheet.Cells(endRow, endCol))

'Transfer
olderVariant = olderRange 

For currentRow = 1 to UBound(olderVariant, 1)
   'Loop
   'if you want change real Cell value Or interior
   'add row Or Col weight
   if olderVariant(currentRow, currentCol) = newerVariant(currentRow, currentCol) THen
      newerSheet.Cells(currentRow+10,currentCol+10).interior.colorIndex = 3
   End if
Next currentRow

Dim Ary1 As Variant, Ary2 As Variant
Dim r As Long

Ary1 = Sheets("Sheet1").UsedRange.Value2
Ary2 = Sheets("Sheet2").UsedRange.Value2
With CreateObject("scripting.dictionary")
   For r = 1 To UBound(Ary1)
      .Item(Ary1(r, 1)) = Empty
   Next r
   For r = 1 To UBound(Ary2)
      If Not .Exists(Ary2(r, 1)) Then Sheets("Sheet2").Cells(r, 1).Interior.Color = vbRed
   Next r
End With