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

[nilem]

На здоровье.
И Вас так же с наступающими!

[Vja4eslav]

Добрый всем день! Вчера уважаемый nilem очень помог мне переделав мой медленно выполняющийся макрос на свой, выполняющийся в течении нескольких секунд. Я посчитал, что смогу дальше справиться сам, но ошибся.
Проблема моя в том, что необходимо не только залить цветом ячейки с дублями, но и получить запись о том сколько дублей имеется и какие именно строки в первом дубле, втором дубле и т.д.
В своём медленном макросе у меня это получилось, а в скоростном макросе nilemа не получается.
Может ли кто-нибудь подсказать, что делать?
Файл с кодами (медленным и быстром) во вложении. В "быстром" коде я уже наворотил что смог, но результата нет.

[Hugo121]

Не нравится мне такой формат вывода. Может так:

Sub findDbl()
    Dim a(), i&
    Dim b(), kk

    With CreateObject("Scripting.Dictionary")
        ' .CompareMode = 1

        a = Range([C1], Range("C" & Rows.Count).End(xlUp)).Value
        For i = 1 To UBound(a)
            If Len(a(i, 1)) Then
                If Not .exists(a(i, 1)) Then
                    .Item(a(i, 1)) = i
                Else
                    Cells(i, 3).Interior.ColorIndex = 3
                    .Item(a(i, 1)) = .Item(a(i, 1)) & ", " & i
                End If
            End If
        Next

        i = 0
        ReDim b(1 To .Count, 1 To 1)
        For Each kk In .keys
            If InStr(.Item(kk), ",") Then
                i = i + 1
                b(i, 1) = .Item(kk)
            End If
        Next
        [e5].Resize(i, 1) = b
    End With
End Sub

Если нужно покрасить и первый из повторяющихся:

                    Cells(i, 3).Interior.ColorIndex = 3
                    If InStr(.Item(a(i, 1)), ",") = 0 Then Cells(.Item(a(i, 1)), 3).Interior.ColorIndex = 3

[Vja4eslav]

Уважаемый Hugo121, это то что нужно! Полученные данные в ячейках я обработаю, "прикручу" слова "1 дубль: ", "2 дубль: " и т.д.
Я очень благодарен Вам за помощь!

[Hugo121]

Прикрутить несложно так - массив b создать на две колонки, в первую писать "1 дубль: " и т.д. (использовать i для цифр), во вторую выгружать .Item(kk).
Ну и выгрузить его
[e5].Resize(i, 2) = b

[Vja4eslav]

К моему большому сожалению я пока не знаю что такое "CreateObject" и как с ним обращаться. С "Resize" сталкивался, но не до конца понял. VBA учу самостоятельно без знания английского языка, методом проб.
Поэтому "прикрутил" как сумел, но это работает:

For i = 5 To [E5].End(xlDown).Row
If Cells(i, 5).Value <> vbNullString Then
Cells(i, 5).Value = Cells(i, 5).Value & "; "
Cells(i, 4).Value = i - 4 & "дубль: " & Cells(i, 5).Value
End If
Next

Спасибо Вам большое за помощь!

[Vja4eslav]

Уважаемый Hugo121, не подскажете, пожалуйста, как найти совпадения по нескольким (например, четырём) столбцам одновременно, т.е. совпадением строк считается если в строках совпали все четыре ячейки в каждом из столбцов?
Я это смог сделать (файл прилагаю), но опять таки макрос работает недопустимо медленно, а "CreateObject" пока не понял.

[Vja4eslav]

Обращаюсь ко всем спецам VBA! Может ли кто-нибудь, пожалуйста, помочь в этом вопросе?

[Hugo121]

Если делать на словаре (ключевое слово "Scripting.Dictionary", а не CreateObject), то всё просто - делаете исходный массив из 4-х столбцов, склеиваете данные (текст) всех 4-х ячеек в одну строку через разделители, её запоминаете в словаре, остальное не меняете.

Sub Инфо_о_дублях()
    Dim a(), i&
    Dim b(), kk
'Tm = Timer
    With CreateObject("Scripting.Dictionary")
         .CompareMode = 1 'т.к. сравниваем уже текст, то может пригодиться

        a = Range([C1], Range("F" & Rows.Count).End(xlUp)).Value
        For i = 1 To UBound(a)
        tmp = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
            If Len(tmp) > 3 Then ' если там не одни палки
                If Not .exists(tmp) Then 'если нет в словаре
                    .Item(tmp) = i 'заносим в словарь с номером строки
                Else 'если уже есть в словаре
                    .Item(tmp) = .Item(tmp) & ", " & i 'добавляем к номеру текущий
                End If
            End If
        Next

        i = 0
        ReDim b(1 To .Count, 1 To 2)
        For Each kk In .keys
            If InStr(.Item(kk), ",") Then 'если в номерах есть запятая (т.е.были повторы)
                i = i + 1
                b(i, 1) = i & " дубль: "
                b(i, 2) = .Item(kk)
            End If
        Next
        [i5].Resize(i, 2) = b
    End With
'MsgBox (Timer - Tm)
End Sub

[nilem]

вот так попробуйте

Sub Инфо_о_дублях2()
Dim x, i&, k&, s$, it: Application.ScreenUpdating = False
x = Range("C5:F" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If Len(x(i, 1)) Then
            s = x(i, 1) & "|" & x(i, 2) & "|" & x(i, 3) & "|" & x(i, 4)
            If Not .exists(s) Then
                .Item(s) = i + 4
            Else
                Cells(i + 4, 3).Interior.Color = vbRed
                k = .Item(s): Cells(k, 3).Interior.Color = vbRed
                .Item(s) = .Item(s) & ", " & i + 4
            End If
        End If
    Next: s = vbNullString
    For Each it In .items
        If InStr(it, ",") Then
            s = s & "дубль строки: " & it & vbCrLf
        End If
    Next
End With
[d2] = s: Application.ScreenUpdating = True
End Sub