仅在电子表格中查找和留下重复项 [英] Finding and leaving only duplicates in spreadsheet

问题描述

在Excel中，我创建了一个宏，以便在当前选择中的多个列中查找并保留重复的值 - 删除只发现一次的单元格。那么，至少这就是我以为我创造的，但它似乎不起作用。这是我所得到的：

  Sub FindDupsRemoveUniq（）
 Dim c As Range 
 Dimcount（ ）As String 
对于每个c在selection.Cells 
 Dim already_found As Boolean 
 already_found =包含（计数，c.Text）
如果没有（已经发现）和WorksheetFunction.CountIf选择，c）< = 1然后
 c.Delete Shift：= xlUp 
 ElseIf（<> c.Text）And Not（already_found）然后
如果Len （计数））= 0然后
 ReDim计数（1）
 Else 
 ReDim保存计数（UBound（计数）+ 1）
结束如果
计数（UBound计数） -  1）= c.Text 
结束If 
下一步c 
 End Sub 
 
私有函数包含（ByRef arr（）As String，cell As String） As Boolean 
 Dim i As Integer 
 Contains = False 
如果Len（Join（arr））= 0然后
退出函数
如果
对于i = LBound（arr）到UBound（arr）
如果cell = arr（i）Then 
 Contains = True 
退出函数
结束如果
下一个
结束函数
  

我不得不这样做，因为我有多个列的约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 =进度：
 Application.EnableEvents = False 
 Application.Calculation = xlCalculationManual 
 Application.ScreenUpdating = False 
 Application.StatusBar = progress_str& 0 of& total_cells& ：0％done
对于lRow = 1对于UBound（sel，1）
对于lCol = 1 To UBound（sel，2）
 counter = counter + 1 
应用程序.StatusBar = progress_str&柜台of& total_cells& ：&格式（计数器/ total_cells，0％）
如果WorksheetFunction.CountIf（selection，sel（lRow，lCol））< 2然后
 sel（lRow，lCol）= vbNullString 
 End If 
 Next lCol 
 Next lRow 
 selection = sel 
 Application.StatusBar =删除空格...
 selection.SpecialCells（xlCellTypeBlanks）.Delete Shift：= xlUp 
 Application.StatusBar =Done
 Application.Calculation = xlCalculationAutomatic 
 Application.ScreenUpdating = True 
 Application.EnableEvents = True 
 End Sub 
  

我试图加快速度一些优化，虽然我不知道他们帮助多少。此外，状态栏更新最终也是没有意义的，因为Excel陷入僵局。似乎在〜300次迭代之后放弃更新。

解决方案

我建议使用数组，与 simoco

此方法删除单元格内容，但不会移动单元格，因为我不清楚你想要这个

  Sub Kill_Unique（）
 Dim X 
 Dim lngRow As Long 
 Dim lngCol As Long 
 X = Selection.Value2 
对于lngRow = 1对于UBound（X，1）
对于lngCol = 1对于UBound（X，2）
如果Application.CountIf（Selection，X（lngRow，lngCol ）） 2然后X（lngRow，lngCol）= vbNullString 
下一页lngCol 
下一页lngRow 
 Selection.Value2 = X 
 End Sub 
  pre> 
In Excel, I created a macro to find and leave only duplicated values across multiple columns within the current selection--removing any cells that were only found once.  Well, at least that's what I thought I created anyway, but it doesn't seem to work.  Here's what I've got:
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
I had to do this because I had ~180k items across multiple columns, and I had to find anything that was duplicated, and under which column those duplicates are showing in.  However, when it completes, it seems that most of the singular instances are still there.  I can't figure out why this isn't working.

EDIT: This is what my code ended up looking like based on @brettdj's solution below:
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
I tried to speed things up with a few optimizations, though I'm not sure how much they helped.  Also, the status bar updates ended up being rather pointless too since Excel got so bogged down.  It seemed to give up updating after ~300 iterations.  Nonetheless, it did work.
解决方案
I would suggest using an array, same approach otherwise as simoco

This approach removes the cell contents but doesn't shift the cells up as I wasn't clear that you wanted this
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


                        
这篇关于仅在电子表格中查找和留下重复项的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！