excel - 在电子表格中仅查找和保留重复项

Question

在 Excel 中，我创建了一个宏来查找并仅在当前选择的多个列中保留重复值——删除仅找到一次的任何单元格。好吧，至少那是我认为我创造的东西，但它似乎不起作用。这是我所拥有的:

Sub FindDupsRemoveUniq()
    Dim c As Range
    Dim counted() As String
    For Each c In selection.Cells
        Dim already_found As Boolean
        already_found = Contains(counted, c.Text)
        If Not (already_found) And WorksheetFunction.CountIf(selection, c) <= 1 Then
            c.Delete Shift:=xlUp
        ElseIf ("" <> c.Text) And Not (already_found) Then
            If Len(Join(counted)) = 0 Then
                ReDim counted(1)
            Else
                ReDim Preserve counted(UBound(counted) + 1)
            End If
            counted(UBound(counted) - 1) = c.Text
        End If
    Next c
End Sub

Private Function Contains(ByRef arr() As String, cell As String) As Boolean
    Dim i As Integer
    Contains = False
    If Len(Join(arr)) = 0 Then
        Exit Function
    End If
    For i = LBound(arr) To UBound(arr)
        If cell = arr(i) Then
            Contains = True
            Exit Function
        End If
    Next
End Function

我必须这样做，因为我在多个列中有大约 180k 项，我必须找到任何重复的内容，以及这些重复项显示在哪一列中。但是，当它完成时，似乎大多数单数实例都是还在那里。我不知道为什么这不起作用。

编辑:这就是我的代码最终基于@brettdj 的解决方案如下所示:

Sub FindDupsRemoveUniq()
    Dim lRow As Long
    Dim lCol As Long
    Dim total_cells As Long
    Dim counter As Long
    Dim progress_str As String
    Dim sel
    sel = selection.Value2
    total_cells = WorksheetFunction.Count(selection)
    counter = 0
    progress_str = "Progress: "
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.StatusBar = progress_str & "0 of " & total_cells & " : 0% done"
    For lRow = 1 To UBound(sel, 1)
        For lCol = 1 To UBound(sel, 2)
            counter = counter + 1
            Application.StatusBar = progress_str & counter & " of " & total_cells & " : " & Format(counter / total_cells, "0%")
            If WorksheetFunction.CountIf(selection, sel(lRow, lCol)) < 2 Then
                sel(lRow, lCol) = vbNullString
            End If
        Next lCol
    Next lRow
    selection = sel
    Application.StatusBar = "Deleting blanks..."
    selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    Application.StatusBar = "Done"
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

我试图通过一些优化来加快速度，但我不确定它们有多大帮助。此外，由于 Excel 陷入困境，状态栏更新也变得毫无意义。它似乎在大约 300 次迭代后放弃了更新。尽管如此，它确实奏效了。

Answer 1

我建议使用数组，其他方法与 simoco 相同

这种方法会删除单元格内容，但不会向上移动单元格，因为我不清楚您是否想要这个

Sub Kill_Unique()
Dim X
Dim lngRow As Long
Dim lngCol As Long
X = Selection.Value2
For lngRow = 1 To UBound(X, 1)
    For lngCol = 1 To UBound(X, 2)
        If Application.CountIf(Selection, X(lngRow, lngCol)) < 2 Then X(lngRow, lngCol) = vbNullString
    Next lngCol
Next lngRow
Selection.Value2 = X
End Sub