比较不同工作表中的两列

Question

我创建了一个宏来比较不同工作表中的两列，并用绿色突出显示匹配的单元格

但问题是两列都超过了 9000 行，所以如果我使用这个

for i =1 to lastrow 

它将占用超过 5 分钟的匹配值并给出结果

 Dim i As Variant, j As Integer, k As Integer


'lastRow = Sheets(1).Range("A1").End(xlDown).Row

'lastrow1 = Sheets(2).Range("A1").End(xlDown).Row
lastRow = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
lastRow1 = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row
     For i = 8 To 9252
If Sheets(1).Cells(i, 1).Value <> "" Then

   For j = 1 To 9252
        If Sheets(1).Cells(i, 4).Value = Sheets(2).Cells(j, 1).Value Then
            Sheets(1).Cells(i, 4).Interior.ColorIndex = 4

        End If
        Next j
 Else
    i = i + 1
    End If
    Next i

我想要的是找到一个解决方案来使用 Lastrow 比较两列并找到一个没有延迟的有效解决方案

有人对此有所了解吗？

最好的问候 马球

Answer 1

您只想在 Sheet2 上查找 Sheet1 中的值； Sheet2 上是否有多个匹配值无关紧要。 Application.Match 将比遍历所有行更快地找到相同的值。

dim i as long, f as variant

with workSheets(1)
    for i=8 to .Cells(.Rows.Count, "A").End(xlUp).Row
        f = application.match(.cells(i, "A").value2, workSheets(2).columns("A"), 0)
        if not iserror(f) then
            .cells(i, "A").Interior.ColorIndex = 4
        end if
    next i
end with

使用您原来的双循环，即使在 Sheet2 的第 10 行中找到了 Sheet1 的值，您仍然通过循环进行比较，直到第 9252 行。Sheet1 中的单元格只能着色一次。

Answer 2

一种方法是使用字典作为集合数据结构来保存工作表 2 中的值，然后在工作表 1 中使用该字典。这会将您的二次算法更改为线性算法：

Sub ColorMatches()
    Dim i As Long
    Dim lastRow As Long
    Dim R As Range, cl As Range
    Dim D As Object
    Dim vals As Variant

    'load dictionary from sheet 2
    Set D = CreateObject("Scripting.Dictionary")
    lastRow = Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
    vals = Sheets(2).Range("A8:A" & lastRow).Value
    For i = LBound(vals) To UBound(vals)
        If Not D.exists(vals(i, 1)) Then D.Add vals(i, 1), 0
    Next i

    'use dictionary in sheet 1
    lastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    Set R = Sheets(1).Range("A1:A" & lastRow)
    For Each cl In R.Cells
        If D.exists(cl.Value) Then cl.Interior.ColorIndex = 4
    Next cl

End Sub

作为一个很小但可能很重要的一点：请注意，我使用 Long 表示 i 而不是 Integer 表示行索引（就像您在代码中所做的那样）。现代版本的 Excel 的行数超过了 Integer 变量所能表示的行数，而且 16 位整数很可能使用 32 位存储，因此使用 Integer 只是冒着溢出而没有相应收益的风险。

Answer 3

我相信这应该可以解决问题。我不是专家，但通过艰难的方式学到了一个简单的教训：您与工作表的互动越少，它的工作速度就越快！

Option Explicit                                                             'Is worth using this option, so you remember declaring your variables

Sub SO()

Dim i As Long, j As Long, k As Long
Dim arrRange1 As Variant, arrRange2 As Variant, arrColor As Variant         'Declare arrays
ReDim arrColor(0)                                                           'Initial redim

Dim lastRow As Long                                                         'Only need to use one variable for this, and reassign as needed through the code
Dim sh1 As Worksheet: Set sh1 = ThisWorkbook.Sheets("RandomSheetName 1")    'Declare sheet 1
Dim sh2 As Worksheet: Set sh2 = ThisWorkbook.Sheets("RandomSheetName 2")    'Declare sheet 2

    With sh1
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row                    'Get last row from sheet 1 in column "A"
        arrRange1 = .Range(.Cells(8, 4), .Cells(lastRow, 4))                'Get all values from column "D", starting at row 8
    End With
    With sh2
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row                    'Get last row from sheet 2 in column "A"
        arrRange2 = .Range(.Cells(1, 1), .Cells(lastRow, 1))                'Get all values from column "A", starting at row 1
    End With

    For i = LBound(arrRange1) To UBound(arrRange1)                          'Loop through first sheet values
        If arrRange1(i, 1) <> "" Then                                       'If not empty, then...
            For j = LBound(arrRange2) To UBound(arrRange2)                  'Loop through second sheet values
                If arrRange1(i, 1) = arrRange2(j, 1) Then                   'If match, then...
                    ReDim Preserve arrColor(k)                              'Redim (preserve) the colours array
                    arrColor(k) = i + 7                                     'Add the value of i in the colours array (note +7, since yours sheet1 values start at row 8, feel free to amend)
                    k = k + 1                                               'Increase the counter for the colours array
                    Exit For                                                'As per idea from the accepted response, no point to check the whole sheet2 range if duplicate found already
                End If
            Next j
        End If
    Next i

    Application.ScreenUpdating = False                                      'It always helps to turn off the screenupdating when working with the sheets
    For i = LBound(arrColor) To UBound(arrColor)                            'Loop through the colours array
        If arrColor(0) = "" Then Exit For                                   'If the first element is empty, means no matches... exit here.
        sh1.Cells(arrColor(i), 4).Interior.ColorIndex = 4                   'Colour the cell as needed using the value we previously stored
    Next i
    Application.ScreenUpdating = True                                       'And lets not forget to turn it on again

End Sub

PS：请注意，Rows.Count 的计数来自ActiveSheet，而不是来自Sheet1 或Sheet2。您需要充分参考，即：Sheets(1).Rows.Count

所以这个：

lastRow = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row

应该是

lastRow = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row

或

With Sheets(1)
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

希望这会有所帮助！