Yardım yinelenenleri kaldır macrosu

Sub DelDups_OneList()

    Dim iListCount As Integer

    Dim iCtr As Integer

  

    ' Turn off screen updating to speed up macro.

    Application.ScreenUpdating = False

  

    ' Get count of records to search through.

    iListCount = Sheets("Sheet1").Range("A1:A100").Rows.Count

    Sheets("Sheet1").Range("A1").Select

    ' Loop until end of records.

    Do Until ActiveCell = ""

       ' Loop through records.

       For iCtr = 1 To iListCount

          ' Don't compare against yourself.

          ' To specify a different column, change 1 to the column number.

          If ActiveCell.Row <> Sheets("Sheet1").Cells(iCtr, 1).Row Then

             ' Do comparison of next record.

             If ActiveCell.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then

                ' If match is true then delete row.

                Sheets("Sheet1").Cells(iCtr, 1).Delete xlShiftUp

                   ' Increment counter to account for deleted row.

                   iCtr = iCtr + 1

             End If

          End If

       Next iCtr

       ' Go to next record.

       ActiveCell.Offset(1, 0).Select

    Loop

    Application.ScreenUpdating = True

    MsgBox "Done!"

    End Sub

Sub DelDups_OneList()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim dict As Object
    Dim key As Variant
    
    ' Turn off screen updating to speed up macro.
    Application.ScreenUpdating = False
    
    ' Set worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Set range to the column you want to check for duplicates
    Set rng = ws.Range("A1:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    
    ' Create a dictionary to store unique values
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Loop through cells in the range
    For Each cell In rng
        ' Check if value is already in dictionary
        If Not dict.Exists(cell.Value) Then
            ' If not, add it to the dictionary
            dict.Add cell.Value, 1
        Else
            ' If it's a duplicate, mark for deletion
            cell.EntireRow.Delete
        End If
    Next cell
    
    ' Turn on screen updating
    Application.ScreenUpdating = True
    
    MsgBox "Done!"
End Sub