alle Duplikate in einer ausgewählten Spalte der Excel-Tabelle

Question

Hier ist der Hintergrund:

• Inventar Tabelle mit 1000 ListRows
• Eine Spalte, die Seriennummern enthält
• ich eine bedingte Formatierung erstellt haben, Färben alle Duplikate in dieser Spalte
• Allerdings würde ich mag zu zeigen alle Duplikate, um sie miteinander
• zu vergleichen, da ich usi bin ng eine Tabelle und wie die Verwendung ihrer Filterfunktion, Ich möchte Zeilen nicht ausblenden. Wenn ich dann alle Filter in der Tabelle löschte, blieben diese Zeilen verborgen. Also möchte ich diesen Teil vermeiden.

So wie ich alle Duplikate zeigen als Filter in einer Tabelle?

Answer 1

Sub ShowDuplicatesInSelectedColumn() 
Dim Cel As Range, Rw&, Col&, NoOfOcc&, Rng As Range 
Dim Tbl As ListObject, Lst$(1 To 1000), Nr&, LstNr&, AlreadyExists As Boolean 

    Application.ScreenUpdating = False 
    Set Tbl = ActiveSheet.ListObjects(1) 
    With Tbl 

     ' Shows all data rows 
     .AutoFilter.ShowAllData 
     Col = Selection.Column 
     Set Rng = .ListColumns(Col).DataBodyRange 

     ' Loop through all rows to check for duplicates 
     For Rw = .ListRows.Count To 1 Step -1 
      Set Cel = .ListColumns(Col).DataBodyRange(Rw) 

      ' Counts the number of occurences 
      With Application.WorksheetFunction 
       NoOfOcc = 0 
       NoOfOcc = .CountIf(Rng, Cel.Value) 
      End With 

      If NoOfOcc > 1 Then 
       ' Check if the value is already in the array 
       AlreadyExists = False 
       For LstNr = 1 To Nr 
        If Cel.Text = Lst(LstNr) Then AlreadyExists = True 
       Next LstNr 

       ' If the value wasn't found in the array, we'll add it 
       If AlreadyExists = False Then 
        Nr = Nr + 1 
        Lst(Nr) = Cel.Text 
       End If 
      End If 
     Next Rw 

     ' Now we'll check how many duplicates that were found 
     If Nr = 1 Then 
      ' If we only found one duplicate 
      With .ListColumns(Col) 
       .Range.AutoFilter Field:=Col, Criteria1:=Lst(1), Operator:=xlFilterValues 
      End With 
     ElseIf Nr > 1 Then 

      ' Creates an array based on the list that was created above 
      ReDim Arr(1 To UBound(Lst)) 
      For Rw = 1 To Nr 
       Arr(Rw) = Lst(Rw) 
      Next Rw 

      ' Filters all duplicates 
      With .ListColumns(Col) 
       .Range.AutoFilter Field:=Col, Criteria1:=Arr, Operator:=xlFilterValues 
      End With 
     End If 
    End With 
    Application.ScreenUpdating = True 
End Sub