Удаление одинаковых строк

[olgomets]

Про шерстил много подобных задач но везде ищут дубликаты и удаляют, оставляя при этом одну строку. Мне же в моей задаче нужно находить дубликаты (полностью идентичные строки в которых все значения во всех столбцах совпадают) и удалять и исходную строку и дублера. Оставив только уникальные строки у которых изначально во всем диапазоне не было дубликатов. Для примера приложу две таблицы исходную и желаемый результат.

[Elixi]

Сообщение от olgomets

Мне же в моей задаче нужно находить дубликаты (полностью идентичные строки в которых все значения во всех столбцах совпадают) и удалять и исходную строку и дублера. Оставив только уникальные строки у которых изначально во всем диапазоне не было дубликатов. Для примера приложу две таблицы исходную и желаемый результат.

Так ваш пример не совпадает с тем что вы излагаете. Например обозначение 20-0000107 Шайба... в исходной таблице находится два раза, но строки не во всех столбцах полностью идентичные. Количество так в одном случае 59 во втором 53. И вы обе строки удалили. Так что тут что-то не совсем корректно. Либо задача, либо показанный желаемый результат. (20-0000105 Шайба - то же самое).

[olgomets]

Сообщение от Elixi

Так ваш пример не совпадает с тем что вы излагаете. Например обозначение 20-0000107 Шайба... в исходной таблице находится два раза, но строки не во всех столбцах полностью идентичные. Количество так в одном случае 59 во втором 53. И вы обе строки удалили. Так что тут что-то не совсем корректно. Либо задача, либо показанный желаемый результат. (20-0000105 Шайба - то же самое).

Виноват. Вы совершенно правы. Удалял вручную. Долго бился с этой проблемой и глаз замылился. Выкладываю исправленный файл с желаемым результатом.

[Elixi]

Sub olgomets_dubli()
'   https://programmersforum.ru/showthread.php?t=346178
' запускайте при активном листе исходной таблицы вашего файла
' макрос создает копию листа и вней удалит дубли
    Dim M(), Rw&, RwL&, Co&, CoL&, i&, Udalim As Boolean
    Dim RngToDel$, RwsToDel As Object
    Set RwsToDel = CreateObject("Scripting.Dictionary")
    
    RwL = Cells(Rows.Count, 1).End(xlUp).Row
    CoL = Cells(1, Columns.Count).End(xlToLeft).Column
    M = Range(Cells(1, 1), Cells(RwL, CoL))

    For Rw = LBound(M, 1) To UBound(M, 1) - 1
        For i = Rw + 1 To UBound(M, 1)
            If M(i, LBound(M, 2)) = M(Rw, LBound(M, 2)) Then
                For Co = 1 + LBound(M, 2) To UBound(M, 2)
                    If M(i, Co) = M(Rw, Co) Then
                        Udalim = True
                    Else
                        Udalim = False: Exit For
                    End If
                Next Co
                If Udalim Then
                    Udalim = False
                    If Not RwsToDel.Exists(Rw) Then
                        RwsToDel.Add Rw, Rw
                    End If
                    If Not RwsToDel.Exists(i) Then
                        RwsToDel.Add i, i
                    End If
                End If
            End If
        Next i
    Next Rw

    For i = 0 To RwsToDel.Count - 1
        RngToDel = RngToDel & RwsToDel.items()(i) & ":" _
                            & RwsToDel.items()(i) & ","
    Next i
    RngToDel = Mid(RngToDel, 1, Len(RngToDel) - 1)
    Set RwsToDel = Nothing
    
    Application.ScreenUpdating = False
        ActiveSheet.Copy Before:=ActiveSheet
        Range(RngToDel).Delete Shift:=xlUp
    Application.ScreenUpdating = True
    
End Sub

[olgomets]

Принято. Спасибо. Буду пробовать.

[Elixi]

olgomets, предыдущий макрос устраняет только ограниченное количество строк.
Следующий должен устранять не ограниченное.

Sub olgomets_dubli_v2()
'   https://programmersforum.ru/showthread.php?t=346178
' запускайте при активном листе исходной таблицы вашего файла
' макрос создает копию листа и вней удалит дубли
    Dim M(), Rw&, RwL&, Co&, CoL&, i&, Udalim As Boolean
    Dim RngToDel As Range, RwsToDel As Object
    Set RwsToDel = CreateObject("Scripting.Dictionary")
    
    ActiveSheet.Copy Before:=ActiveSheet
    RwL = Cells(Rows.Count, 1).End(xlUp).Row
    CoL = Cells(1, Columns.Count).End(xlToLeft).Column
    M = Range(Cells(1, 1), Cells(RwL, CoL))

    For Rw = LBound(M, 1) To UBound(M, 1) - 1
        For i = Rw + 1 To UBound(M, 1)
            If M(i, LBound(M, 2)) = M(Rw, LBound(M, 2)) Then
                For Co = 1 + LBound(M, 2) To UBound(M, 2)
                    If M(i, Co) = M(Rw, Co) Then
                        Udalim = True
                    Else
                        Udalim = False: Exit For
                    End If
                Next Co
                If Udalim Then
                    Udalim = False
                    If Not RwsToDel.Exists(Rw) Then
                        RwsToDel.Add Rw, Rw
                    End If
                    If Not RwsToDel.Exists(i) Then
                        RwsToDel.Add i, i
                    End If
                End If
            End If
        Next i
    Next Rw

    For i = 0 To RwsToDel.Count - 1
        If RngToDel Is Nothing Then
            Set RngToDel = Range(RwsToDel.items()(i) & ":" _
                            & RwsToDel.items()(i))
        Else
            Set RngToDel = Union(RngToDel, _
                            Range(RwsToDel.items()(i) & ":" _
                            & RwsToDel.items()(i)))
        End If
    Next i
    Set RwsToDel = Nothing
    If Not RngToDel Is Nothing Then RngToDel.Delete
    
End Sub

[сфинкс]

Строки из многих ячеек контролируются вручную

=СЦЕПИТЬ(A5;B5;C5;D5;E5)

=ЕСЛИ(G5=G6;1;"")

Вдруг подобные задачи другим понадобятся

https://www.youtube.com/watch?v=I0QV2AZ5W5E

[olgomets]

Elixi, Огромное спасибо все отлично работает так как задумывалось.