时间戳

首页 > 解决方案 > 比较两张工作表并仅使用唯一 ID 突出显示不匹配的行

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

标签： excelvba

解决方案

让我们简化任务并逐步完成。

  • 两张表中的输入如下所示：

在此处输入图像描述

在此处输入图像描述

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

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

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

在此处输入图像描述

这是整个代码的样子：

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)

推荐阅读