從Excel中的A列中刪除所有重復項

Question

我正在尋找一個可以從列A中刪除所有重復項的宏。

輸入：

John
Jimmy
Brenda
Brenda
Tom
Tom
Todd

輸出：

John
Jimmy
Todd

我正在使用大量數據，Excel不合作。 似乎無法找到有效的在線解決方案。

謝謝！

Answer 1

當你想要重復刪除列表時，確保每個項目只剩下一個項目，你可以這樣做：

在Excel 2007及更高版本中，您可以在“數據”菜單中找到“刪除重復項”，它將為您執行此操作。

在Excel 2003及更早版本中，您可以使用“數據/過濾器”菜單中的“高級過濾器”：

然后將結果復制粘貼到新工作表中。

你可以在這里看到完整的程序。

否則，它是一個繁瑣的宏（一個遞歸循環來檢查集合中是否存在該值）。 它可以做到，但你真的需要嗎？

但是如果你想要刪除所有相同的條目，那么使用@Eoins的宏將完成這項工作，但稍作修改如下：

Option Explicit

Sub DeleteDuplicate()
    Dim x, Y As Long
    Dim LastRow As Long
    Dim myCell As String
    LastRow = Range("A1").SpecialCells(xlLastCell).Row
    For x = LastRow To 1 Step -1
        myCell = Range("A" & x).Text
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), myCell) > 1 Then
            For Y = x To 1 Step -1
                If Range("A" & Y).Text = myCell Then
                    Range("A" & Y).EntireRow.Delete
                End If
            Next Y
        End If
    Next x
End Sub

Answer 2

由於您的請求是針對宏，請嘗試以下方法：

Excel 2007+

ActiveSheet.Range("A:A").RemoveDuplicates

這是Excel 2003的選項

Option Explicit

Sub DeletDuplicate()
    Dim x As Long
    Dim LastRow As Long
    LastRow = Range("A65536").End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
        Range("A" & x).EntireRow.Delete
      End If
  Next x
End Sub

Answer 3

這是一個遞歸循環，以防你想要它:)

它實際上是2個程序，第一個程序對列表進行排序，第二個程序刪除重復項

'----------------------------------------------------------------------
'--SORT A 1D ARRAY NUMERICALLY-ALPHABETICALLY(TAKEN FROM StackOverflow)
'----------------------------------------------------------------------
    Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)

        Dim pivot   As Variant
        Dim tmpSwap As Variant
        Dim tmpLow  As Long
        Dim tmpHi   As Long

        tmpLow = inLow
        tmpHi = inHi

        pivot = vArray((inLow + inHi) \ 2)

        While (tmpLow <= tmpHi)

            While (vArray(tmpLow) < pivot And tmpLow < inHi)
                tmpLow = tmpLow + 1
            Wend

            While (pivot < vArray(tmpHi) And tmpHi > inLow)
                tmpHi = tmpHi - 1
            Wend

            If (tmpLow <= tmpHi) Then
                tmpSwap = vArray(tmpLow)
                vArray(tmpLow) = vArray(tmpHi)
                vArray(tmpHi) = tmpSwap
                tmpLow = tmpLow + 1
                tmpHi = tmpHi - 1
            End If

        Wend

        If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
        If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi

    End Sub


'---------------------------------------
'--REMOVE DUPLICATES AND BLANKS FROM SORTED 1D ARRAY
'---------------------------------------
Public Function RemoveDuplicatesBlanks_1DSorted(Arr As Variant) As Variant

    Dim i As Long, iMin As Long, iMax As Long, Cnt As Long
    Dim TArr As Variant, TArr2() As Variant

    TArr = Arr
    iMin = LBound(TArr)
    iMax = UBound(TArr)

    i = iMin

    Do While i <= iMax
        If TArr(i) = vbNullString Then
            Cnt = Cnt + 1
        ElseIf i < iMax Then
            If TArr(i) = TArr(i + 1) Then
                TArr(i) = Empty
                Cnt = Cnt + 1
            End If
        End If
        i = i + 1
    Loop

    ReDim TArr2(iMin To (iMax - Cnt))

    Cnt = iMin

    For i = iMin To iMax
        If Not TArr(i) = vbNullString Then
            TArr2(Cnt) = TArr(i)
            Cnt = Cnt + 1
        End If
    Next i

    RemoveDuplicatesBlanks_1DSorted = TArr2
End Function

這些設置的方式你會像這樣使用它們.....

QuickSort MyArray, LBound(MyArray), UBOUND(MyArray)

MyArray = RemoveDuplicatesBlanks_1DSorted(MyArray)

這些只適用於1維數組，如果需要，我也可以將它們用於2維數組。

我已經多次使用它們並且它們非常快，比大多數方法快得多，因此如果你有大型列表，那么使用這些方法是值得的。

- - 附加信息 - -

ExtractArrayColumn函數位於此代碼之下....此處的代碼是您如何使用所有這些過程

Private sub RemoveDuplicate()
    Dim MyRangeArray As Variant, MyArray As Variant
    MyRangeArray = Range("A1:A100").Value

    MyArray = ExtractArrayColumn(MyRAngeArray,1)

    QuickSort MyArray, LBound(MyArray), UBOUND(MyArray)

    MyArray = RemoveDuplicatesBlanks_1DSorted(MyArray)

    Range("A1:A100").Value = MyArray
End Sub







Public Function ExtractArrayColumn(Array_Obj As Variant, Column_Index As Long) As Variant
    Dim TArr() As Variant
    Dim L1 As Long, H1 As Long
    Dim i As Long

    L1 = LBound(Array_Obj, 1)
    H1 = UBound(Array_Obj, 1)

    ReDim TArr(L1 To H1)

    For i = L1 To H1
        TArr(i) = Array_Obj(i, Column_Index)
    Next i

    ExtractArrayColumn = TArr
End Function