Как считать в массив и найти дубли

[Vja4eslav]

Добрый всем день!
Написал макрос, который ищет: есть ли дубли в стобце и заливает цветом ячейки с дублями. Если количество строк небольшое (до 1000), то время выполнения программы устраивает, а если строк несколько десятков тысяч, то время очень не устраивает. Предполагаю, что надо диапазон считать в массив и в нём уже перебирать.Т.к. VBA осваиваю самостоятельно, методом тыка, то нужных знаний не хватает, если кто- то может помочь, то очень вас прошу.
Код, который я написал вот он:

Sub Найти_дубли()
Dim i As Long, ii As Long, sch As Long, ARange As Range, a As Range, oRow As Long, str As Long
Application.ScreenUpdating = False
Tm = Timer
For str = 65536 To 5 Step -1
If Cells(str, 3).Value <> vbNullString Then str = str: Exit For
Next
Set ARange = Range(Cells(5, 3), Cells(str, 3))
For Each a In ARange
a = Application.WorksheetFunction.Trim( a)
Next
ARange.Interior.ColorIndex = xlNone

''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''
i = 5
Do
ii = i + 1
Do
If Cells(ii, 3).Interior.ColorIndex = 3 Then GoTo dalee
If Cells(i, 3).Value = Cells(ii, 3).Value Then
Cells(i, 3).Interior.ColorIndex = 3
Cells(ii, 3).Interior.ColorIndex = 3
End If
dalee:
ii = ii + 1
Loop While ii <= str
Application.StatusBar = "Обрабатывается " & i - 4 & " строка из " & str - 4
i = i + 1
Loop While i <= str
''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''


pipec:
With Application
.ScreenUpdating = False
.StatusBar = False
End With
MsgBox (Timer - Tm)
End Sub

[nilem]

Попробуйте так:

Sub Найти_дубли2()
Dim x, i As Long, s As String
Application.ScreenUpdating = False
With Range("C5", Cells(Rows.Count, 3).End(xlUp))
    .Interior.ColorIndex = xlNone
    x = .Value
End With
On Error Resume Next
With New Collection
    For i = 1 To UBound(x)
        s = Trim(x(i, 1))
        If IsEmpty(.Item(s)) Then
            .Add 1, s
        Else
            Cells(i + 4, 3).Interior.ColorIndex = 3
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

или вот так по-модному

Sub ertert()
Dim x, i As Long: Application.ScreenUpdating = 0
With Range("C5", Cells(Rows.Count, 3).End(xlUp))
    .Interior.ColorIndex = xlNone
    x = Application.Trim(.Value)
End With
With CreateObject("System.Collections.ArrayList")
    For i = 1 To UBound(x)
        If Not .Contains(x(i, 1)) Then
            .Add x(i, 1)
        Else
            Cells(i + 4, 3).Interior.ColorIndex = 3
        End If
    Next
End With: Application.ScreenUpdating = 1
End Sub

[Vja4eslav]

Спасибо, nilem! А как подправить Ваш код, чтобы он закрашивал обе одинаковые ячейки ?

[nilem]

наверное, так

Sub Найти_дубли3()
Dim x, i As Long, k As Long, s As String
Application.ScreenUpdating = False
With Range("C5", Cells(Rows.Count, 3).End(xlUp))
    .Interior.ColorIndex = xlNone
    x = .Value
End With
On Error Resume Next
With New Collection
    For i = 1 To UBound(x)
        s = Trim(x(i, 1))
        If IsEmpty(.Item(s)) Then
            .Add i, s
        Else
            Cells(i + 4, 3).Interior.ColorIndex = 3
            k = .Item(s)
            Cells(k + 4, 3).Interior.ColorIndex = 3
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

[Vja4eslav]

Спасибо ! Способ, который "по-модному" мне больше понравился из-за отсутствия On Error Resume Next, если Вас не затруднит, немогли бы Вы, пожалуйста, в нём дописать закраску обеих ячеек ?

[nilem]

Дело в том, что у ArrayList есть только ключи, айтемз нет (в этом случае нужны коллекции типа SortedList), поэтому давайте возьмем словарь (тоже пока еще в моде)

Sub ertert2()
Dim x, i As Long, k As Long: Application.ScreenUpdating = 0
With Range("C5", Cells(Rows.Count, 3).End(xlUp))
    .Interior.ColorIndex = xlNone
    x = Application.Trim(.Value)
End With
With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(x)
        If Not .Exists(x(i, 1)) Then
            .Item(x(i, 1)) = i
        Else
            Cells(i + 4, 3).Interior.ColorIndex = 3
            k = .Item(x(i, 1))
            Cells(k + 4, 3).Interior.ColorIndex = 3
        End If
    Next
End With: Application.ScreenUpdating = 1
End Sub

[Vja4eslav]

Очень Вам благодарен, nilem !!!

[Vja4eslav]

Опасаюсь показаться наглым и навязчивым. Уважаемый nilem, моих знаний не хватает, чтобы подправить Ваш последний код так, чтобы он не окрашивал пустые ячейки. Понимаю, что всякому терпению есть предел, но если Вас не очень затруднит, не могли бы Вы, пожалуйста, дописать это в коде ?

[nilem]

да ладно

Sub ertert3()
Dim x, i As Long, k As Long: Application.ScreenUpdating = 0
With Range("C5", Cells(Rows.Count, 3).End(xlUp))
    .Interior.ColorIndex = xlNone
    x = Application.Trim(.Value)
End With
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            If Not .Exists(x(i, 1)) Then
                .Item(x(i, 1)) = i
            Else
                Cells(i + 4, 3).Interior.ColorIndex = 3
                k = .Item(x(i, 1))
                Cells(k + 4, 3).Interior.ColorIndex = 3
            End If
        End If
    Next
End With: Application.ScreenUpdating = 1
End Sub

[Vja4eslav]

Большое спасибо! Поздравляю Вас с наступающими праздниками!