Могу ли я сделать этот макрос / код быстрее?(Excel VBA Duplication Finder)

Question

Я использую следующий код для выделения двух столбцов с повторяющимися записями.

Sub ChkDup()
'Declare All Variables
Dim myCell As Range
Dim matRow As Integer
Dim batRow As Integer
Dim matRange As Range
Dim batRange As Range
Dim m As Integer
Dim b As Integer

'set rows as we know them
matRow = 1000
batRow = 1000

'Loop each column to check duplicate values & highlight them.
For m = 3 To matRow
Set matRange = Range("A3:A1000")

'Loop, and highlight all matching materials
For Each myCell In matRange
If WorksheetFunction.CountIf(matRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 3
End If
Next
Next

'Loop again for batches
For b = 3 To batRow
Set batRange = Range("B3:B1000")
For Each myCell In batRange
If WorksheetFunction.CountIf(batRange, myCell.Value) > 1 Then
myCell.Interior.ColorIndex = 6
End If
Next
Next

End Sub

Два столбца имеют «отдельные» дубликаты, так как это только когда значения мата и летучей мыши совпадают с тем, что я ищу.Я мог бы искать это конкретное условие программно, но мой VBA, по меньшей мере, плох.

Область имеет 1000 строк, и она должна проверять один столбец за раз.Макрос занимает около 40 секунд, чтобы выделить каждый столбец.Это ожидаемое время?Могу ли я сделать это быстрее, не делая это слишком сложным?Мне может понадобиться расширить поиск до 10000 строк.

Вот пример данных.

Answer 1

У вас есть ненужный цикл, сидящий поверх каждого дублирующего цикла проверки.Это должно замедлить ваш код.

Я отредактировал ваш код.Он должен работать быстрее и давать такие же результаты!

Sub ChkDupRevised()
    'Declare All Variables
    Dim myCell As Range
    Dim chkRow As Long
    Dim chkRange As Range

    'set rows as we know them
    chkRow = 1000

    'check column A
    Set chkRange = Range("A3:A" & chkRow)
    For Each myCell In chkRange
        If WorksheetFunction.CountIf(chkRange, myCell.Value) > 1 Then
            myCell.Interior.ColorIndex = 3
        End If
    Next

    'check column B
    Set chkRange = Range("B3:B" & chkRow)
    For Each myCell In chkRange
        If WorksheetFunction.CountIf(chkRange, myCell.Value) > 1 Then
            myCell.Interior.ColorIndex = 6
        End If
    Next

End Sub