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”）行，并传入一个空范围作为第一个参数

与蛮力迭代方法相比，它闪电般快速：它在不到一秒的时间内处理了2个包含2000个项目的列表（对于暴力攻击方法，则为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

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

2 个答案: