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

Posted by obzor under VBA

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

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

тема на форуме

Похожие статьи

• Изменить цвет шрифта TextBox на форме
• Сравнение двух диапазонов ячеек Excel на полное совпадение данных
• Что в календаре Excel возвращает дату?
• Как закрыть папку в Excel средствами VBA без имитации нажатия клавиш?
• Реакция на клик по ячейке в Excel
• Как в Excel сделать так, чтобы при нажатии на ячейку менялось цифровое значение?
• Cчитывание измеренной температуры с датчика DS18B20 в Excel, используя библиотеку RSAPI.DLL
• Интерфейс между Outlook и Excel
• Как в Excel убрать панель формул с определенного окна?
• Выбрать 3 ячейки vba excel 2003 за одно действие