Question

以下是背景资料：

1000 listrows的库存表
一列包含序列号
我创建了一个条件格式，为该列中的所有重复项着色
但是，我想显示所有重复项，以便将它们相互比较
由于我正在使用表格并喜欢使用其过滤功能，我不想隐藏行。因为那时，如果我清除了表中的所有过滤器，那些行将保持隐藏状态。所以我想避开那一部分。

那么如何在表格中显示所有重复作为过滤器？

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

在Excel表的选定列中显示所有重复项

1 个答案: