Макрос для поиска и удаления дубликатов в 2 массивах

[Екатерина Максимова]

На одном листе есть две таблицы разделенные несколькими строками - это и есть 2 массива. Нужно проверить дублирующиеся значения между ними, но есть сложность - иногда одно и тоже значение повторяется в одном массиве из-за чего иногда некорректно отображаются данные. Хотелось бы создать код, который может избежать этой ошибки. Как я представляю процесс: берется значение из массива №1 и сравнивается со значениями из массива №2(сравнение идет только по столбику "Номер заявки"); при нахождении повтора эти два значения исключаются из сравнения(если есть такое же значение в массиве №1, то при сравнении уже не будет в массиве №2 такого же);если дубликатов нет, то строка со значением переносится на отдельный лист(то есть из таблицы 1 оставить записи, которые не совпадают со значениями таблицы 2).

При этом хотелось бы чтобы все эти вычисления были виртуальными, никак не изменяя реальный документ.
Это вообще возможно?

Пока создала только такой код

Код Выделить Развернуть

Dim lLastRow2
        lLastRow2 = Cells(Rows.Count, 2).End(xlUp).Row + 4
        Dim x, m
        For x = 2 To Cells(Rows.Count, 2).End(xlUp).Row
        For m = lLastRow2 To Cells(Rows.Count, 2).End(xlUp).Row
        If Cells(x, 2) > 0 Then
        If Cells(m, 2) > 0 Then
            If Cells(x, 2) = Cells(m, 2) Then
...и дальше я не знаю что вставить

[kuklp1]

Код Выделить Развернуть

Public Sub www()
    Dim a, dc As Object, i&, r As Range, lr&, lr1&
    Sheets("Не дубликаты").UsedRange.Clear
    Set dc = CreateObject("scripting.dictionary")
    Set r = Range("a1:f" & [a1].End(xlDown).Row)
    a = r.Value
    For i = 1 To UBound(a)
        dc.Item(a(i, 2)) = i
    Next
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    lr1 = Cells(lr, 1).End(xlUp).Row
    Set r = Range("a" & lr1 & ":f" & lr)
    a = r.Value
    For i = 1 To UBound(a)
        If dc.exists(a(i, 2)) Then dc.Remove (a(i, 2))
    Next
    a = dc.items: dc.RemoveAll: Set dc = Nothing
    For i = 0 To UBound(a)
        Cells(a(i), 1).Resize(, 5).Copy Sheets("Не дубликаты").Cells(Rows.Count, 1).End(xlUp)(2)
    Next
End Sub

[Екатерина Максимова]

К сожалению, не то...данный код ищет просто дубли...а если брать по примеру должно скопировать 2 строки 3(как не имеющую дубля во 2-й таблице) и 4(имеется дубль в 1 и 2 таблице, то есть дубль один раз закрывается и ещё один номер как бы больше не имеет дубля во 2-й таблице)...

Мне помогли и подсказали код, может еще кому-нибудь сгодиться

Код Выделить Развернуть

Sub tt()
Dim a, b, i&, ii&, lr&, t$, col As New Collection, tmp&

With Sheets(1) 'работаем с первым листом
    lr = .Cells(.Rows.Count, 2).End(xlUp).Row 'последняя строка
    a = .[a1].CurrentRegion.Columns(2).Value 'массив данных из верхней непрерывной части
    b = .Cells(lr, "A").CurrentRegion.Columns(2).Value 'массив из нижней

On Error Resume Next 'отключение ошибок
For i = 1 To UBound(b) 'цикл по нижнему массиву
    t = b(i, 1): col.Add 1, t 'попытка добавить в коллекцию номер в текстовом виде с счётчиком
    If Err Then ' если не добавилось, т.е. уже есть
    tmp = col(t) 'запоминаем значение счётчика
    col.Remove (t) 'удаляем из коллекции
    col.Add tmp + 1, t 'добавляем с увеличенным счётчиком
    Err.Clear 'сбрасываем ошибку
    End If
Next

Err.Clear 'сбрасываем ошибку, на всякий - по идее тут ошибки быть не должно
For i = 1 To UBound(a) 'цикл по верхнему массиву
    t = a(i, 1): col.Add t, t 'попытка добавить в коллекцию номер в текстовом виде
    If Err = 0 Then 'если нет ошибки, т.е. добавилось
        ii = ii + 1: .Rows(i).Copy Sheets(2).Cells(ii, 1) 'копируем строку на второй лист
        col.Remove (t) 'удаляем из коллекции только что добавленное
    Else 'если ошибка была, т.е не добавилось
        tmp = col(t) 'запоминаем значение счётчика
        col.Remove (t) 'удаляем из коллекции
        If tmp > 1 Then col.Add tmp - 1, t 'если счётчик >1 то добавляем с уменьшенным счётчиком
        Err.Clear 'сбрасываем ошибку
    End If
Next

End With
End Sub

[IKor]

Екатерина Максимовна,

При этом хотелось бы чтобы все эти вычисления были виртуальными, никак не изменяя реальный документ.

С учетом этого Вашего пожелания ИМХО гораздо проще воспользоваться возможностями условного форматирования: при помощи которого выделять цветом (шрифта или фона) те ячейки, значения которых более одного раза встречаются в основном и дополнительном столбцах:

Код Выделить Развернуть

=СЧЁТЕСЛИ($A$1:$F$1;A$1)>1
=СЧЁТЕСЛИ($A$1:$F$1;A$10)>0