Сравните два листа и выделите несопоставленные строки, используя только уникальный идентификатор

Question

Я хочу сопоставить строки из двух разных листов и выделить только в первом столбце несопоставленной строки или, что еще лучше, скопировать несопоставленные строки в новый лист. Код должен сравнить строки двух листов и раскрасить новые строки на втором листе. Sheet2 (скажем, январь 2020 г.) содержит больше строк, чем Sheet1 (De c 2019) в качестве недавно обновленного листа, и они оба содержат строки размером более 22 КБ, причем оба имеют уникальный идентификатор в качестве первого столбца.

Мой ниже Код пытается выделить все несовпадающие ячейки и занимает больше времени, чтобы завершить sh. То, что я sh должен сделать так, чтобы код просто окрашивал непревзойденные значения только в столбце A (vb.Red) (поскольку он является уникальным идентификатором), игнорируя при этом оставшуюся часть столбца / ячеек (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

Answer 1

Давайте упростим задачу и сделаем это шаг за шагом.

• Вот как могут выглядеть входные данные на двух листах:

Затем мы можем рассмотреть их чтение и сохранение в массиве:

---

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

• Цикл между данными в двух массивах довольно быстро в VBA . Запись на третий лист выполняется только после совпадения двух значений из двух массивов:

---

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)

Answer 2

Если у кого-то возникла такая же проблема, я нашел более простой способ сделать это. Предоставление вашего листа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

Answer 3

когда вы получаете значение ячейки, оно тратит время.

, так что вы можете нацелиться на дальность передачи 2d Variant

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