logo标签列表

在Excel中删除A列中的所有重复项

vbaexcel
3
我正在寻找一个宏，可以从A列中删除所有重复项。
输入：
John
Jimmy
Brenda
Brenda
Tom
Tom
Todd

输出：

John
Jimmy
Todd

我正在处理一大批数据，但 Excel 不太配合。似乎在网上找不到可行的解决方案。
谢谢！
3
你有没有查看数据选项卡上的“删除重复项”功能？Excel已经有一个可以执行此操作的函数。 - Scott Craner
1
@ScottCraner 我不会因为这个而给她投反对票。Excel 2003及更早版本没有此“删除重复项”功能。所以这是一个有效的问题。我编辑了帖子，以使这一点清楚。 - ib11
2
@ib11 首先，我不是那个给你点了踩的人，除非我听到了原帖作者的回复，否则我也不会这么做。其次，你从哪里得出原帖作者在使用2003的结论？我只看到你这样假设并把它写进了问题中。我正在等待一个问题的答案。编辑们在别人的问题上加入自己的解释并不是很合适，除非你有证据证明原帖作者确实在使用2003，否则你只是在猜测。这和假设他们不知道如何去重一样糟糕。就我个人而言，除非你有证据，否则我会撤销这个编辑。 - Scott Craner
1
@ScottCraner 实际上，我刚刚意识到 OP 的输出不仅要删除重复的内容，还要删除被重复的内容：两者都要。这是一种不同的方法。现在，那个不是 Excel 函数，需要使用 VBA 宏来实现。 - ib11
1
@ib11，那么Excel的版本就不重要了。我已经删除了所有特定版本的标签和原文中不存在的措辞。 - Scott Craner
3个回答
3
当您想要去重列表时，也就是确保每个项只剩下一个时，您可以执行以下操作：
在Excel 2007及以上版本中，您可以使用“数据”菜单中的“删除重复项”来完成此操作。
在Excel 2003及更早版本中，您可以使用“数据/筛选器”菜单中的“高级筛选器”。

enter image description here

然后将结果复制粘贴到新工作表中。

您可以在这里看到完整的过程。

否则，编写一个冗长的宏来检查值是否存在于集合中会很烦琐（需要递归循环）。虽然可以完成，但您真的需要吗？

但是，如果您想要实际删除所有相同的条目，则可以使用@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
1
您仍然可以使用高级筛选器来消除所有重复项。只需使用一个公式条件，检查每个条目的计数是否恰好为1。 - Ron Rosenfeld
非常感谢！宏运行得非常好。我已经尝试了Excel的所有选项，包括您提出的高级筛选，但是它花费的时间太长了，而且Excel在尝试运行超过500,000行时一直崩溃。你太棒了！ - Brenda
@BrendaTonLinkous 非常感谢您的提问。这是一个非常聪明的问题。正如您所看到的，它引发了相当多的活动。 - ib11
@BrendaTonLinkous 我修改了另一个点，即它独立地检测最后一行有多少行（之前是任意设置的，现在是绝对的最后一行）。 - ib11
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
请注意，此方法仅适用于Excel 2007及以上版本，请查看问题下方的评论，因此请在您的答案中包含此信息。 - ib11
顺便说一句，你关于反向循环的解决方案真是一个聪明的方法，我点赞了。 - ib11
感谢您的反馈！ - EoinS
谢谢您发送过来的内容，这个解决方案与删除重复项功能相同，但这不是我想要的。它保留了唯一值，而我想要删除所有重复项。 - Brenda
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)

这些方法仅适用于一维数组，如果您需要二维数组的话我也有相应的方法。

我已经多次使用这些方法，它们非常快速，比大多数方法都要快，所以如果您有大型列表，值得使用这些方法。

----附加信息----

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
1
你的代码对于数组很有用，但请将其改为适用于OP问题的解决方案，即如何从Excel表格中特定的A列中删除重复项。同时请注意，您不一定需要对该列进行排序！我的意思是，请修改您的答案以回答这个问题。 - ib11
1
打乱列表的顺序意味着顺序不重要...... 这个去重算法需要排序，如果 OP 需要其他方面的帮助，他们只需要问一下即可。我会更新答案，包括使其起作用所需的所有必要代码..... - Paul S
这可能有点过头了，但至少它应该能完成工作。 - Paul S
很好。但你知道吗，我读了她的帖子第五遍后，终于明白了她的意思。请看我的评论和我在答案中发布的代码。 - ib11
哈，我也错过了，如果不是这样的话，那么每个人都没能帮上忙，哈哈。 - Paul S
哈哈，难怪我读了5遍！但是我的答案确实包含了代码，所以如果她回来的话，她会有它的;-) - ib11
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接