vba - VBAですべての重複行を削除する

Question

VBA マクロを使用して、すべての重複行 (最初の列に重複が存在する場合) を削除する方法を探しています。

現在、Excel マクロは、最初のインスタンスを除いてすべての重複インスタンスを削除しますが、これは私が望んでいるものではありません。絶対除去してほしい。

Answer 1

朝の素早いトレーニングのために行われた少し短い解決策：

Sub quicker_Option()

    Dim toDel(), i As Long
    Dim RNG As Range, Cell As Long
    Set RNG = Range("a1:a19") 'set your range here

    For Cell = 1 To RNG.Cells.Count
        If Application.CountIf(RNG, RNG(Cell)) > 1 Then
            ReDim Preserve toDel(i)
            toDel(i) = RNG(Cell).Address
            i = i + 1
        End If
    Next
    For i = UBound(toDel) To LBound(toDel) Step -1
        Range(toDel(i)).EntireRow.Delete

    Next i

End Sub

Answer 2

後で削除するために、最初のインスタンスのセルを保存します。次に、重複を最後まで削除します。

Dim F as integer, S as integer   'indices for First and Second cells to be compared
Dim Deleted as boolean         'indicates if second line was deleted
Dim First as Range, Second as Range   'First and second cells to be compared
Dim Start as string                   'Indicates the position of the first cell's start

Start = "A1"   'can be as you like
Set First = Sheet1.Range(Start)  'Sets the start cell

F = 0          '
Do While First.Value <> ""    'loop while sheet contains data in the column 
    S = F + 1                 'second cell is at least 1 cell below first cell
    Deleted = false           'no second cell was deleted yet
    Set Second = First.Offset(S,0)      'second cell is an offset of the first cell

    Do While Second.Value <> ""       'loop while second cell is in sheet's range with data
        if Second.Value = First.Value then    'if values are duplicade
            Second.EntreRow.Delete              'delete second cell
            Deleted = true                       'stores deleted information
        else                                'if not, second cell index goes next
            S = S + 1;
        end if

        Set Second = First.Offset(S, 0)      'sets second cell again (if deleted, same position, if not deleted, next position
    Loop

    if Deleted then         'if deleted, should delete first cell as well
        First.EntireRow.Delete
    else
        F = F + 1           'if no duplicates found, first cell goes next
    end if

    Set First = Sheet1.Range(Start).Offset(F,0)     'sets first cell again (if deleted, same position, if not, next)
Loop