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

在Excel中，我创build了一个macros来查找和保留当前select中的多个列中的重复值 – 删除所有只发现一次的单元格。 那么，至less这就是我认为我创build的东西，但它似乎并没有工作。 这是我得到的：

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项目跨越多列，我必须find任何重复的东西，并在这些列重复显示在哪个列。但是，当它完成时，似乎大多数奇异实例还在那儿。 我不明白为什么这不起作用。

编辑：这是我的代码结束了看起来像基于@ brettdj的解决scheme如下：

 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 

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

Answer 1

我会build议使用一个数组，否则相同的方法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

如果你想从select中删除所有具有唯一值的单元格，试试这个：

 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