Makro do usuwania dubli VB-Excel

 To makro pozwala usunąć zdublowane komórki lub wiersze.



Sub UsuńDuplikaty()
Dim Ark  As Worksheet
Dim ostA        As Long
Dim zakres  As Range
Dim doUsunięcia As Range
Dim ile          As Long

Application.ScreenUpdating = False

Set Ark = ThisWorkbook.Worksheets("Arkusz1")
With Ark
        ostA = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A1:A" & ostA).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        Set zakres = .Range("A1:A" & ostA).SpecialCells(xlCellTypeVisible)
        On Error Resume Next
                .ShowAllData
        On Error GoTo 0
        zakres.Rows.Hidden = True
        On Error GoTo koniec
     
        Set doUsunięcia = .Range("A1:A" & ostA).SpecialCells(xlCellTypeVisible)
       
        ile = doUsunięcia.Cells.Count
         
        'doUsunięcia.EntireRow.Delete Shift:=xlUp             'usuwa cały wiersz
       
        doUsunięcia.Delete Shift:=xlUp                  'usuwa tylko komórkę
       
wyjście:
Application.ScreenUpdating = True
        .Rows.Hidden = False
        If ile > 0 Then MsgBox "Usunięto wpisów: " & ile, vbInformation
        Set zakres = Nothing
        Set doUsunięcia = Nothing
Exit Sub

koniec:
        .Rows.Hidden = False
        MsgBox "Brak dancy do usuniecia"
        Resume wyjście
End With
End Sub