在VBA中比较和突出显示数千行的好方法

Question

我有一些代码可以将A列中的每个单元格与B列中的所有单元格进行比较，并为指定的行数执行此操作。

当我有几百行时，这很好，但现在我发现有2000行，代码不会削减它。任何人都可以查看我的代码并告诉我是否有一些改进，或者我是否应该废弃它并以不同方式执行。

Sub highlight()

Dim compare As String
Dim i As Integer
Dim comprange As Range
Dim lines As Integer
i = 2
ScreenUpdating = False

Range("a2").Select
lines = Application.InputBox(Prompt:="How many lines need to be compared?", 
_
Title:="SPECIFY RANGE", Type:=1)

Do Until IsEmpty(ActiveCell)

    If i + 1 > lines Then
        Exit Do
    End If

Set comprange = Range("A" & i)
    comprange.Select
    compare = comprange.Value
    i = i + 1

    Range("B2").Select
        Do Until IsEmpty(ActiveCell.Offset(1, 0))

            If ActiveCell.Value = compare Then
                ActiveCell.Interior.ColorIndex = 37
                ActiveCell.Offset(1, 0).Select
                Exit Do
            Else
                If IsEmpty(ActiveCell.Offset(1, 0)) Then
                    Exit Do
                Else
                ActiveCell.Offset(1, 0).Select
                End If
            End If
        Loop
    Loop
    compare = ActiveCell.Value
    Set comprange = Selection
    Range("a2").Select
    Do Until IsEmpty(ActiveCell.Offset(1, 0))

            If ActiveCell.Value = compare Then
                comprange.Interior.ColorIndex = 37
                ActiveCell.Offset(1, 0).Select
                Exit Do
            Else
                If IsEmpty(ActiveCell.Offset(1, 0)) Then
                    Exit Do
                Else
                ActiveCell.Offset(1, 0).Select
                End If
            End If
        Loop
End Sub

Answer 1

试试这个，它将检查A列中的所有值以及它是否与B列高亮相匹配。

Sub ok()
    Dim i, i2 As Long
    Dim LastRow, LastRow2 As Long

    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    With ActiveSheet
        LastRow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    For i = 1 To LastRow
        For i2 = 1 To LastRow2
            If Range("A" & i).Value = Range("B" & i2).Value Then
                Range("A" & i).Interior.ColorIndex = 37
                Range("B" & i2).Interior.ColorIndex = 37
            End If
        Next
    Next
End Sub

Answer 2

可能最有效的方法是使用VBA Dictionary对象。在https://www.experts-exchange.com/articles/3391/Using-the-Dictionary-Class-in-VBA.html有一篇很棒的文章，涵盖了你需要知道的很多内容。

下面是一个名为DuplicatesBetweenLists的函数，它将突出显示任意数量的不同范围之间的重复项。在调用它时，您可以指定：

• 将重复列表转储到的范围（如果不希望生成列表，则传入空范围）
• 是否要突出显示重复项目
• 要检查的所有范围的ParamArray（以逗号分隔的列表）。

因此，如果您想检查下图中的所有三列以查找每列中出现的条目，并希望将列表输出到任何重复项的单元格E1以及在数据中突出显示它们，您可以将该函数调用为这个：

Sub test()

    Dim rOutput As Range

    Set rOutput = Range("E1")
    DuplicatesBetweenLists rOutput, True, Range("A2:A11"), Range("B2:B11"), Range("C2:C11")

End Sub

......这会给你这样的东西：

但是如果你只想要突出显示并且不希望识别的重复输出到一个范围，你只需注释掉Set rOutput = Range（“E1”）行，并传入一个空范围作为第一个参数。

与蛮力迭代方法相比，它闪电般快速：它在不到一秒的时间内处理了包含2000个项目的2个列表（对于蛮力方法，则为1分钟）。它只需12秒即可处理2个200,000个项目的列表。

这是函数本身，以及它调用的另一个函数：

Function DuplicatesBetweenLists(rOutput As Range, bHighlight As Boolean, ParamArray Ranges() As Variant)

    Dim vRange      As Variant
    Dim vInput      As Variant
    Dim dic_A       As Object
    Dim dic_B       As Object
    Dim dic_Output  As Object
    Dim lOutput     As Long
    Dim lRange      As Long
    Dim cell        As Range
    Dim TimeTaken As Date

    TimeTaken = Now()

    Set dic_A = CreateObject("Scripting.Dictionary")
    Set dic_B = CreateObject("Scripting.Dictionary")
    Set dic_Output = CreateObject("Scripting.Dictionary")
    Set dic_Range = CreateObject("Scripting.Dictionary")

    lRange = 1

    For Each vRange In Ranges
         vInput = vRange
        DuplicatesBetweenLists_AddToDictionary vInput, lRange, dic_A, dic_B
    Next vRange

    If lRange Mod 2 = 1 Then
        Set dic_Output = dic_B
    Else: Set dic_Output = dic_A
    End If

    'Write any duplicate items back to the worksheet
    If Not rOutput Is Nothing Then
        If dic_Output.Count > 0 Then
            If dic_Output.Count < 65537 Then
                rOutput.Resize(dic_Output.Count) = Application.Transpose(dic_Output.Items)
            Else
                'The dictionary is too big to transfer to the workheet
                'because Application.Transfer can't handle more than 65536 items.
                'So well transfer it to an appropriately oriented variant array,
                ' then transfer that array to the worksheet WITHOUT application.transpose
                ReDim varOutput(1 To dic_Output.Count, 1 To 1)
                For Each vItem In dic_Output
                    lOutput = lOutput + 1
                    varOutput(lOutput, 1) = vItem
                Next vItem
                rOutput.Resize(dic_Output.Count) = varOutput
            End If
        End If
    End If

    'Highlight any duplicates
    If bHighlight Then
        'Highlight cells in the range that qualify
        Application.ScreenUpdating = False
        For Each vRange In Ranges
            'Set rInput = vRange
            vRange.Interior.ColorIndex = 0
            For Each cell In vRange
                 With cell
                    If dic_Output.Exists(.Value2) Then .Interior.Color = 65535
                End With
            Next cell
        Next vRange
        Application.ScreenUpdating = True
        TimeTaken = TimeTaken - Now()
        Debug.Print Format(TimeTaken, "HH:MM:SS") & "(HH:MM:SS)"
    End If


'Cleanup
Set dic_A = Nothing
Set dic_B = Nothing
Set dic_Output = Nothing



End Function





Private Function DuplicatesBetweenLists_AddToDictionary(varItems As Variant, ByRef lngRange As Long, ByVal dic_A As Object, ByVal dic_B As Object)
Dim lng As Long
Dim dic_dedup As Object
Dim varItem As Variant
Dim lPass As Long
Set dic_dedup = CreateObject("Scripting.Dictionary")

For lPass = 1 To UBound(varItems, 2)
    If lngRange = 1 Then
        'First Pass: Just add the items to dic_A
        For lng = 1 To UBound(varItems)
            If Not dic_A.Exists(varItems(lng, 1)) Then dic_A.Add varItems(lng, 1), varItems(lng, 1)
        Next
    Else:
    ' Add items from current pass to dic_Dedup so we can get rid of any duplicates within the column.
    ' Without this step, the code further below would think that intra-column duplicates were in fact
    ' duplicates ACROSS the columns processed to date

    For lng = 1 To UBound(varItems)
        If Not dic_dedup.Exists(varItems(lng, lPass)) Then dic_dedup.Add varItems(lng, lPass), varItems(lng, lPass)
    Next

    'Find out which Dictionary currently contains our identified duplicate.
    ' This changes with each pass.
    '   * On the first pass, we add the first list to dic_A
    '   * On the 2nd pass, we attempt to add each new item to dic_A.
    '       If an item already exists in dic_A then we know it's a duplicate
    '       between lists, and so we add it to dic_B.
    '       When we've processed that list, we clear dic_A
    '   * On the 3rd pass, we attempt to add each new item to dic_B,
    '       to see if it matches any of the duplicates already identified.
    '       If an item already exists in dic_B then we know it's a duplicate
    '       across all the lists we've processed to date, and so we add it to dic_A.
    '       When we've processed that list, we clear dic_B
    '   * We keep on doing this until the user presses CANCEL.

    If lngRange Mod 2 = 0 Then
        'dic_A currently contains any duplicate items we've found in our passes to date
        'Test if item appears in dic_A, and IF SO then add it to dic_B
        For Each varItem In dic_dedup
            If dic_A.Exists(varItem) Then
                If Not dic_B.Exists(varItem) Then dic_B.Add varItem, varItem
            End If
        Next
        dic_A.RemoveAll
        dic_dedup.RemoveAll

    Else 'dic_B currently contains any duplicate items we've found in our passes to date

        'Test if item appear in dic_B, and IF SO then add it to dic_A
        For Each varItem In dic_dedup
            If dic_B.Exists(varItem) Then
                If Not dic_A.Exists(varItem) Then dic_A.Add varItem, varItem
            End If
        Next
        dic_B.RemoveAll
        dic_dedup.RemoveAll
        End If
    End If
    lngRange = lngRange + 1
Next

End Function