OFF Nordheim, здравствуйте! Начал ускорять свой код, добавил словарь, пишу, значится, а потом смотрю, что у меня примерно ваш код получается, только гораздо примитивнее Расскажите, пожалуйста — этой строкой dic.Item(txt) = dic.Item(txt) + 1 мы заносим ключ в словарь и сразу считаем одинаковые? Не до конца понимаю, как работает это колдунство…
Матчасть всё та-же и в ней сказано, что при добавлении дубля ключа этим способом произойдёт замена. Получается, что мы считаем замены?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: Матчасть всё та-же и в ней сказано, что при добавлении дубля ключа этим способом произойдёт замена. Получается, что мы считаем замены?
Совершенно верно, это своеобразный счетчик замен (в нашем случае совпадений).
"Все гениальное просто, а все простое гениально!!!"
OFF Nordheim, фигасе опять приятно удивили спасибо вам большое! Как допишу код - гляньте, пожалуйста, на предмет критики, если получится там будет кое-что моё)))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Nordheim, помню, что вы говорили об xl в качестве хобби)) многое от вас узнаю - поэтому и попросил)) спасибо за науку)
Итак - вот код, почти точная копия кода от Nordheim. Перепробовал различные варианты и немного (на пару %) получилось ускорить. Оказывается, код от кузя1972 также очень похож, но у него отсутствует удаление дублей из источника и за счёт этого минус 2 цикла и выигрыш в 5 раз (30 сек против 150 на 150к строках реальных данных, как в файле). Пыхтел-пытался я сократить количество циклов, но не вышло.
Выводы: рост времени выполнения в геометрической прогрессии (10х) при увеличении количества строк (почти не зависит от количества столбцов) в арифметической. 1,4/13/150сек. для 50/100/150 тысяч строк. Около 80% времени (128 сек на 150к) занимает основной цикл по перезаполнению массива дублями и формированию диапазона для удаления. Для сравнения - на 50к строках этот цикл занимает всего лишь около 20% времени (0,16 сек). Удаление дублей из источника занимает в 2 раза меньшее время - 13 сек на 150к. Все остальные процессы занимают около 5с на 150к.
Ну вот как-то так
КОД
Код
Option Explicit
Sub ПоискДубликатов()
' таблица должна начинаться с ячейки A1 текущего листа
Dim dic As Object, rng As Range, arr(), x
Dim tm!, i&, j As Byte, n&, r&, c%, col As Byte, txt$
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0: Application.Calculation = xlCalculationManual: On Error GoTo er: tm = Timer
arr = [a1].CurrentRegion.Value: r = UBound(arr, 1): c = UBound(arr, 2)
col = 7 ' задаём № столбца-ключа
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To r
txt = arr(i, col)
dic.Item(txt) = dic.Item(txt) + 1
Next i
For Each x In dic.Keys
If dic.Item(x) = 1 Then dic.Remove (x)
Next x
For i = 2 To r
txt = arr(i, col)
If dic.Exists(txt) Then
If rng Is Nothing Then Set rng = Cells(i, 1) Else Set rng = Union(rng, Cells(i, 1))
n = n + 1
For j = 1 To c
arr(n, j) = arr(i, j)
Next j
End If
Next i
If n = r - 1 Then MsgBox "Уникальные ключи отсутствуют…", vbInformation, "НЕТ УНИКАЛЬНЫХ КЛЮЧЕЙ": GoTo ex
If n = 0 Then MsgBox "Дубликаты в ключах отсутствуют…", vbInformation, "ВСЕ КЛЮЧИ УНИКАЛЬНЫ": GoTo ex
rng.EntireRow.Delete
On Error Resume Next: Worksheets("Duplicates").Delete: On Error GoTo er
Worksheets.Add.Name = "Duplicates": Worksheets("Duplicates").Tab.Color = vbGreen
[a1].Resize(n, c).Value = arr
MsgBox "Дубли (" & n & ") строк вырезаны!" & vbLf & vbLf & "Время работы макроса (сек.): " & Round(Timer - tm, 2), vbInformation, "ГОТОВО"
GoTo fin
er: MsgBox "Непредвиденная ошибка!", vbCritical, "FATAL ERROR"
ex: MsgBox "Отмена выполнения…", vbInformation, "EXIT"
fin: Application.DisplayAlerts = 1: Application.ScreenUpdating = 1
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Здравствуйте, коллеги! Если применить "классический" метод удаления строк от Владимира (ZVI), то время выполнения будет O(N*Ln(N)). Думаю, что 15 сек (вместо 150) для 150к строк из примера #38 хватит с запасом.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Если признак в столбце определять формулой, то будет долго (так как столбец Id не отсортирован). А вот если через словари (аналогично #38 и др. сообщениям), то быстро. Естественно, лучше признак вычислить в начале в массиве, а затем перенести из массива в дополнительный столбец.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Добрался до Excel. Иллюстрация к #39 (тщательно не тестировал).
Код
Option Explicit
Sub CutDupl()
Dim rng As Range, dic As Object, sh2 As Worksheet
Dim j1 As Long, j2 As Long, arr1, arr2
Dim n As Long, nrows As Long, i As Long, key, old_calc
Const duplName = "Duplicates"
Set rng = Range("A1").CurrentRegion
j1 = 7 ' номер столбца с ключом
nrows = rng.Rows.Count - 1 ' число строк без заголовка
If nrows <= 2 Then
MsgBox "Число строк диапазона не превышает 2"
Exit Sub
End If
j2 = rng.Columns.Count + 1 ' номер добавленного столбца в rng
Set rng = rng.Offset(1).Resize(nrows, j2)
' без строки заголовка, с добавленным столбцом
Set dic = CreateObject("Scripting.Dictionary")
n = 0 ' счетчик дубликатов
arr1 = rng.Columns(j1).Value
ReDim arr2(1 To nrows, 1 To 1) ' значения для добавленного столбца
For i = 1 To nrows
key = arr1(i, 1) ' ключ
If Not dic.exists(key) Then ' ключ встретился впервые
dic(key) = i ' запомнили индекс массива
arr2(i, 1) = 0
Else
arr2(i, 1) = 1: n = n + 1 ' дубль
If dic(key) > 0 Then ' заносим признак дубля в первую строку с ключом key
arr2(dic(key), 1) = 1: n = n + 1
dic(key) = 0
End If
End If
Next i
If n = 0 Then
MsgBox "Повторов ключей не найдено"
Exit Sub
End If
Set dic = Nothing ' словарь больше не нужен
' Начало корректировки информации книги
With Application
old_calc = .Calculation: .Calculation = xlCalculationManual: .ScreenUpdating = False
With rng
.Columns(j2).Value = arr2
.Sort .Columns(j2), xlAscending, Header:=xlNo
.Columns(j2).ClearContents
End With
' последние n строк диапазона rng - дубли
Set rng = rng.Offset(nrows - n).Resize(n)
On Error Resume Next
Set sh2 = Worksheets(duplName)
On Error GoTo 0
If sh2 Is Nothing Then
Set sh2 = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sh2.Name = duplName
Else
sh2.Cells.Delete
End If
rng.Parent.Activate
With rng.EntireRow
.Copy sh2.Cells(1, 1)
.Delete
End With
.Calculation = old_calc
.ScreenUpdating = True
End With
End Sub
Option Explicit
Sub test()
' ----------------------------------------------
Dim dic As Object, ikey, rng As Range, sht1 As Worksheet
Dim i&, arr(), txt$, j%, x&, sht As Worksheet, dic1 As Object
' ----------------------------------------------
Application.DisplayAlerts = False
Set dic = CreateObject("Scripting.Dictionary")
Set dic1 = CreateObject("Scripting.Dictionary")
On Error Resume Next
Set sht = ThisWorkbook.Worksheets("Дубли")
If Not sht Is Nothing Then sht.Delete
On Error GoTo 0
Set sht1 = Worksheets("Пример на форум")
arr = sht1.UsedRange.Value
For i = 2 To UBound(arr)
txt = arr(i, 7)
If Not dic.exists(txt) Then dic.Item(txt) = 1 Else dic1.Item(txt) = 0: dic.Item(txt) = 1
Next i
x = 1
For i = 1 To UBound(arr)
txt = arr(i, 7)
If dic1.exists(txt) Then
If rng Is Nothing Then Set rng = sht1.Rows(i) Else Set rng = Union(rng, sht1.Rows(i))
x = x + 1
For j = 1 To UBound(arr, 2)
arr(x, j) = arr(i, j)
Next j
End If
Next i
Set sht = ThisWorkbook.Worksheets.Add(after:=sht1)
With sht
.Range("K2:K" & x).NumberFormat = "@"
.[a1].Resize(x, UBound(arr, 2)).Value = arr
.Name = "Дубли"
.Columns.AutoFit
End With
If Not rng Is Nothing Then rng.Delete
Application.DisplayAlerts = True
End Sub
Доброе время суток. Версия на SQL. На 15 столбцах 123000 дублей, 54000 уникальных - 26 секунд. То же на 60 столбцах 86 секунд. Явно проиграет алгоритму Владимиров
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Добрый день, уважаемые форумчане. Попробовал на реальном файле 153 тыс строк макросы от Jack Famous #38 и #44. Оба макроса отработали корректно за 7,5 мин. Попробовал также макрос от Андрей VG #48 - получил ошибку (см. скрин). До макроса от sokol92 пока не добрался, но попробую обязательно. Спасибо всем за ответы и помощь!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Добрый день! Протестировал макрос от sokol92 (пост #43) на своем реальном файл в 153 тыс строк. Это бомба! Невероятно, время работы составило 4,4 сек! И все повторы найдены и перенесены на новый лист со своим форматом. Супер! Спасибо всем, кто откликнулся и принял участие в решении проблемы, и конечно sokol92 - Вам отдельное огромное спасибо!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Теме почти 3 года... но не удержался, чтобы не прокомментировать.
В чем фишка (движок от ZVI)? Стандартное использование словаря. Ну только если сортировка в конце - оригинально, когда для переноса на новый лист будет 150 тысяч дубликатов из 153 тыс. строк одним сплошным диапазоном. Выигрыш по времени действительно сумашедший.
Добрый день! Подскажите, а как сделать чтобы дубликаты искались не по одному столбцу, а по нескольким? Например, если одинаковые значения в первом и пятом столбце тогда строка считается дублирующей.
Анна Казакова, создайте новую тему с примером и помогу
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄