Выборка актуальных данных с удалением оригинальной и дублирующей записи

[Dima36668]

Суть задачи такова:
1) в excel имеется таблица №1 с данными следующего вида (порядка 700 000 строк)

Код А Б С
1 яблоко 12 456
2 груша 13 457
3 перец 14 458
4 помидор 15 459
5 яблоко 12 456
6 груша 13 457
7 перец 15 458
8 помидор 15 458

2) данная таблица импортируется в Access где делается запрос на выборку дублей, в результате получаем следующую таблицу (которую можно выгрузить в excel):

Код А Б С
1 яблоко 12 456
5 яблоко 12 456
2 груша 13 457
6 груша 13 457

3) для получения интересующего результата необходимо из таблицы 1 удалить все строки выбранные в таблицу два - и оригинальную запись и её дубль, (как идентификатор считаю необходимо использовать поле "код")

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

Sub Макрос1()
' Макрос1 Макрос

Sheets("Лист1").Select Range("A2").Select
If "A2"=Sheets("Лист2").Select Range("A2:A70000").Select
Sheets("Лист1").Select
Rows("1:1").Select
Selection.Delete Shift:=xlUp
End Sub


Подскажите, как правильно описать программе данную задачу для её максимально быстрой обработки в excel или access?

Заранее большое спасибо!!!

[Hugo121]

Можно сделать за минуту без Access.
Но без примера файла кода не будет.
Файл нужен на ~100 строк, естественно с повторами.

Т.е. сделать не за минуту
Минуту будет 700000 перебирать. Или быстрее.

[Dima36668]

Вот пример в таблице объединены данные из двух разных источников (отличаются форматированием), необходимо удалять идентичные записи по столбцам с желтой шапкой. Если можно это будет делать без их объедения на 1 листе, - вообще здорово. В данном вложении как минимум 1 дубль точно есть, т.е. как минимум две строки должны быть удалены.

[Hugo121]

С одним листом неинтересно...
Сделал для двух листов - но если закомментировать эти два блока, где идёт обращение к другому листу (1 или 2, всё равно), то можно без переделок использовать с одним этим оставшимся листом.
Интересно, как быстро отработает на 700000 строк (или 2х700000?) - расскажете?

Sub deldoubles()
    Dim a(), i&, t$, arr
    Dim x As Range: Application.ScreenUpdating = False

    With CreateObject("Scripting.Dictionary")
        .comparemode = 1

        a = Sheets(1).[a1].CurrentRegion.Value
        ReDim aa(1 To UBound(a), 1 To 1)
        For i = 2 To UBound(a)
            t = a(i, 1) & "|" & a(i, 5) & "|" & a(i, 6)
            If .exists(t) Then
                aa(i, 1) = 1
                If .Item(t) <> 0& Then aa(Split(.Item(t))(1), 1) = 1: .Item(t) = 0&
            Else
                .Item(t) = "1 " & i
            End If
        Next

        a = Sheets(2).[a1].CurrentRegion.Value
        ReDim bb(1 To UBound(a), 1 To 1)
        For i = 2 To UBound(a)
            t = a(i, 1) & "|" & a(i, 5) & "|" & a(i, 6)
            If .exists(t) Then
                bb(i, 1) = 1
                If .Item(t) <> 0& Then
                    arr = Split(.Item(t)): .Item(t) = 0&
                    If arr(0) = 1 Then aa(arr(1), 1) = 1 Else bb(arr(1), 1) = 1
                End If
            Else
                .Item(t) = "2 " & i
            End If
        Next

    End With

    With Sheets(1)
        .[k1].Resize(UBound(aa), 1).Value = aa
        Set x = .[K:K].Find(1, , , xlWhole)
        If Not x Is Nothing Then
            .[K:K].ColumnDifferences(x).EntireRow.Hidden = True
            .UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .Rows.Hidden = False
        End If
    End With

    With Sheets(2)
        .[k1].Resize(UBound(bb), 1).Value = bb
        Set x = .[K:K].Find(1, , , xlWhole)
        If Not x Is Nothing Then
            .[K:K].ColumnDifferences(x).EntireRow.Hidden = True
            .UsedRange.SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .Rows.Hidden = False
        End If
    End With

    Application.ScreenUpdating = True
End Sub

Если столбец K на листах занят - можно использовать любой другой свободный столбец (не стал эти заморачиваться в коде).
Теоретически можно подумать и сделать для любого динамического количества листов - но думаю практически нет нужды. Да и код это усложнит и думаю затормозит...

[nerv]

Если кто-то знает, подскажите, как правильней/проще сделать?

Sub io()
    Dim ADO As New ADO
    
    ADO.Query "SELECT *", _
              "FROM [Лист1$A:D]", _
                  "WHERE (F2 & '/' & 'F3' & '/' & F4) IN (", _
                      "SELECT (F2 & '/' & 'F3' & '/' & F4)", _
                      "FROM [Лист1$A:D]", _
                      "GROUP BY (F2 & '/' & 'F3' & '/' & F4)", _
                      "HAVING COUNT((F2 & '/' & 'F3' & '/' & F4)) = 1", _
                  ")"

    Range("H1").CopyFromRecordset ADO.Recordset
End Sub

еще перец потерялся : )

[Hugo121]

Александр, а как на примере? Что-то у меня не взлетело (на одном листе - на двух и не пытался...)
Хотел время потестить.
Кстати, на 700000 оно полетит? Или пойдёт?

[Dima36668]

Пока тестил на 400к - порядка 40 минут ожидания....
Но все равно лучше, чем с ВПР мучиться...
Респект с ЯД на ВМ приходит? (не активный пользователь данных систем)
Можно еще попросить закомментировать каждую строчку кода, что бы было понимание и возможность скорректировать в случае необходимости.

[Hugo121]

40 минут? Долго...
Надо бы поанализировать, на каких этапах тормозит. Может там на листе много формул? Тогда может тормозить после выгрузки меток и после удаления строк.
Результат есть?
Про ЯД ничего не знаю. Думаю что опция должна быть
Каждую строку расписывать долго. Но алгоритм такой:
1. данные листа в массив.
1а. создаём массив для пометок, аналогичный по высоте исходному
2. цикл по массиву
3. собираем ключ (из помеченных жёлтым столбцов)
4. проверяем наличие ключа в словаре
4а. если есть - то ставим метку в массив в текущую строку, проверяем item этого ключа в словаре - если не 0, то извлекаем номер строки, помечаем в массиве и её, меняем item на 0.
4б. если ещё нет в словаре - заносим в словарь, ставя в item номер листа и номер строки (через пробел).

Со вторым листом почти всё так же, только при извлечении номера строки извлекаем и номер листа, и в зависимости от этого пишем в первый или второй массив.

Когда все данные проанализированы, удаляемые строки помечены в массивах - выгружаем массивы на листы, скрываем непомеченные строки, видимые удаляем одним действием.

[Скрипт]

Dima36668, попробуйте отключить пересчёт формул на время работы макроса ("Excel 2010"):
вкладка Формулы - группа Вычисление - Параметры вычислений - выберите Вручную.

Запустите макрос и посмотрите, стало ли быстрее.

Если станет быстрее, то можно с помощью макроса включать и отключать пересчёт формул.

[nerv]

а как на примере?

так и на примере