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

Answer 2

如果您想从选择中删除所有唯一值的单元格，请尝试以下方法：

Sub test()
    Dim rngToDelete As Range, c As Range

    For Each c In Selection
        If WorksheetFunction.CountIf(Selection, c) = 1 Then
            If rngToDelete Is Nothing Then
                Set rngToDelete = c
            Else
                Set rngToDelete = Union(rngToDelete, c)
            End If
        End If
    Next

    If Not rngToDelete Is Nothing Then rngToDelete.Delete Shift:=xlUp
End Sub

在电子表格中查找并仅留下重复项

2 个答案: