Поиск дублей excel vba

Excel непознаваем как атом.

Изменено: Jack Famous — 15.08.2018 11:14:43

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

Неизлечимых болезней нет, есть неизлечимые люди.

, автофильтр «видит» только 10 тыс. строк, поэтому этот прием не годится.

Jack Famous

, конечный результат в файле-примере таков: на Листе1 строк с подсвеченными id не должно быть — они должны появиться на другом, вставленном листе. В реальном файле из-за большого количества строк УФ неприменимо.

Excel непознаваем как атом.

, не совсем то, что необходимо: в Вашем решении одна из повторяющихся строк остается на исходном листе. Мне же нужно ВСЕ строки с повторяющимися id вырезать с исходного листа и вставить на другой лист. Честно говоря, я не понял, каким приемом Вы решили задачу. Спасибо за ответ.

Excel непознаваем как атом.

mtts54, пробуйте

UPD (15:05):

14я строка кода Set rng = Cells(1, col).Resize(r+ 1, 1) исправлена на Set rng = Cells(2, col).Resize(r, 1). Файл заменён.

Прикрепленные файлы

Изменено: Jack Famous — 15.08.2018 15:07:53

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

выполните этот макрос

Sub RemoveDouble2NewSheet()
  Dim rg As Range: Set rg = Range(Cells(2, 7), Cells(Rows.Count, 7).End(xlUp))
  rg.Offset(0, 9).FormulaR1C1 = "=if(countif(r2c7:r" & rg.Rows.Count + 1 & "c7, rc7)>1,2,"""")"
  rg.Offset(0, 9).Value = rg.Offset(0, 9).Value
  Set rg = rg.Offset(0, 9).SpecialCells(xlCellTypeConstants, 1).EntireRow: Columns(16).Clear
  rg.Copy Worksheets.Add.Cells(1, 1):  rg.Delete: Columns(16).Clear
End Sub

при активном листе с данными

Изменено: Ігор Гончаренко — 15.08.2018 14:34:29

Программисты — это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

Внешний запрос (Данные-Получение внешних данных…). Измените формулу в столбце Ключ =СЧЁТЕСЛИ($G$2:$G$348;G2), обновите таблицы как указано выше.

Изменено: TheBestOfTheBest — 15.08.2018 14:40:31

Неизлечимых болезней нет, есть неизлечимые люди.

вариант макроса(не нашел как надо в исходном файл -примере),кнопки unic и очистка,лист1 добавлен вручную

Sub unic()
     Dim i&, m&, j&, z, z1: z = Range("A2:O" & Range("A" & Rows.Count).End(xlUp).Row).Value
     ReDim z1(1 To UBound(z), 1 To UBound(z, 2))
 With CreateObject("scripting.dictionary"): .CompareMode = 1
 For i = 1 To UBound(z): .Item(z(i, 7)) = .Item(z(i, 7)) + 1: Next
 For i = 1 To UBound(z)
 If .Item(z(i, 7)) > 1 Then
   m = m + 1: For j = 1 To UBound(z, 2): z1(m, j) = z(i, j): Next
 End If
 Next
 Sheets("Лист1").Range("A1").Resize(m, UBound(z1, 2)).Value = z1
End With
End Sub

Прикрепленные файлы

Excel непознаваем как атом.

Изменено: Jack Famous — 16.08.2018 10:15:51

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

Вариант на массивах и словарях

«Все гениальное просто, а все простое гениально!!!»

Добрый день! Протестировал макрос от

Ігор Гончаренко

на реальном файле размером 31 колонка на 153 тыс.строк. В макросе в выражениях Offset(0, 9) заменил 9 на 25 и в Columns(16)  заменил 16 на 32. Макрос работал ок. 10 минут, нашел все 7696 повторов. Хотелось бы побыстрее, но… размер имеет значение. Спасибо! Остальные решения протестирую завтра.

Excel непознаваем как атом.

Попробовал на том же реальном файле макрос от

Jack Famous

. К сожалению, макрос где-то зациклился и после 20 минут ожидания я был вынужден остановить его выполнение  

Excel непознаваем как атом.

mtts54, немного изменил принцип удаления строк из исходника — пробуйте

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

На том же реальном файле макрос

Nordheim

за 2 секунды нашел все повторы, вставил лист и скопировал повторы туда (правда, пару раз VBA ругнулся: не была объявлена переменная sht1 — это я поправил).  Но с исходного листа макрос повторы не удалил   . Тут я ничего поделать не смог    . Очень надеюсь, что уважаемый  

Nordheim

 прочтет этот пост и подправит код  

Excel непознаваем как атом.

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

В данном коде есть нюанс, таблица должна начинаться со второй строки, шапка таблицы на первой

Option Explicit

 
Sub test()
'   ----------------------------------------------
    Dim dic As Object, ikey, rng As Range
    Dim i&, arr(), txt$, j%, x&, sht As Worksheet
'   ----------------------------------------------
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    Set sht = ThisWorkbook.Worksheets("Дубли")
    If Not sht Is Nothing Then sht.Delete
    On Error GoTo 0
    arr = sht1.UsedRange.Value
    For i = 2 To UBound(arr)
        txt = arr(i, 7)
        dic.Item(txt) = dic.Item(txt) + 1
    Next i
    For Each ikey In dic.Keys
        If dic.Item(ikey) = 1 Then dic.Remove (ikey)
    Next ikey
    x = 1
    For i = 1 To UBound(arr)
        txt = arr(i, 7)
        If dic.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
        .[a1].Resize(x, UBound(arr, 2)) = arr
        .Name = "Дубли"
        .Columns.AutoFit
    End With
    If Not rng Is Nothing Then rng.Delete
    Application.DisplayAlerts = True
End Sub

«Все гениальное просто, а все простое гениально!!!»

Nordheim,  
Определите sht1    

  Set sht1 = ThisWorkbook.Worksheets("Пример на форум")

при формировании листа Дубли я бы добавил первой строку

.Range("K2:K" & x).NumberFormat = "@"

sht1 в файле это название листа в VBAProject, поэтому лист не объявлен, на кириллице неудобно было писать, поэтому переименовал по ходу написания кода

«Все гениальное просто, а все простое гениально!!!»

С какой целью?

«Все гениальное просто, а все простое гениально!!!»

,  макрос (с учетом от

Kuzmich

) отработал немного дольше (это абсолютно не критично), повторы с исходного листа удалил. Спасибо!

kryptonets

, нужен именно макрос, т.к. таблица обрабатывается макросом (моим) и прерывать его для ручной работы неудобно. Тем не менее попробую Вашу идею — лишних знаний ведь не бывает, когда-нибудь пригодится. Спасибо.

Excel непознаваем как атом.

Nordheim, написал

Просто на листе Дубли в столбце К появляются ячейки с янв.92 вместо 1-92

А строка зачем?

«Все гениальное просто, а все простое гениально!!!»

Наверно так более правильно.

Sub test()
'   ----------------------------------------------
    Dim dic As Object, ikey, rng As Range, sht1 As Worksheet
    Dim i&, arr(), txt$, j%, x&, sht As Worksheet
'   ----------------------------------------------
    Application.DisplayAlerts = False
    Set dic = 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)
        dic.Item(txt) = dic.Item(txt) + 1
    Next i
    For Each ikey In dic.Keys
        If dic.Item(ikey) = 1 Then dic.Remove (ikey)
    Next ikey
    x = 1
    For i = 1 To UBound(arr)
        txt = arr(i, 7)
        If dic.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
        End With
        .Name = "Дубли"
        .Columns.AutoFit
    End With
    If Not rng Is Nothing Then rng.Delete
    Application.DisplayAlerts = True
End Sub

«Все гениальное просто, а все простое гениально!!!»