标记和过滤重复 ListObject VBA

Posted 2023-03-27

【中文标题】标记和过滤重复 ListObject VBA

【英文标题】：Mark and Filter duplicates ListObject VBA

【发布时间】：2021-05-04 00:02:20

【问题描述】：

我试图在 ListObject（动态表的列）VBA 中查找、标记和过滤重复项，但没有成功。 以下脚本适用于常规范围，我做了一些更改并需要它用于列表对象。 非常感谢您的帮助

S

sub Duplicates()
    
    ActiveSheet.Shapes("shape3").Select 'change to whatever your shape is called
    If Selection.ShapeRange.Fill.Visible = msoFalse Then
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 40
    Else
    
    Selection.ShapeRange.Fill.Visible = msoFalse
    
    End If
    
    Dim Rng As Range
    Dim cel As Range
    
    'Test for duplicates in a single column
    'Duplicates will be highlighted in red
    
    Set Rng = Range(Range("B1"), Range("B" & Rows.Count).End(xlUp))
    
    For Each cel In Rng
    If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then
    
    cel.Interior.ColorIndex = 3
    End If
    Next cel
    
    Range("B:J").Select
    
    ActiveSheet.Range("$B$1:$J$1").AutoFilter Field:=1, Criteria1:=RGB(255, 0 _
    , 0), Operator:=xlFilterCellColor
    ActiveWindow.SmallScroll Down:=-9
    ActiveSheet.Range("$B$1:$J$1").AutoFilter Field:=9, Criteria1:="<>0", _
    Operator:=xlAnd

End Sub

【参考方案1】：

一种方法是使用条件格式：

Sub FilterDups()
Dim LO As ListObject, FC As UniqueValues

Set LO = ActiveSheet.ListObjects(1) ' Dynamic Table
Set FC = LO.DataBodyRange.Columns(1).FormatConditions.AddUniqueValues   ' UniqueValues object to quickly visualize cells that contain either unique or duplicate values
With FC
    .SetFirstPriority
    .DupeUnique = xlDuplicate
    .Interior.Color = vbRed ' red color for duplicate values
End With

LO.Range.AutoFilter Field:=1, Criteria1:=RGB(255, 255, 255), Operator:=xlFilterNoFill ' filter out duplicate values

结束子