Excel 筛选列中不同值的计数

我有一张6000行的Excel表格。如果一个特定列中的不同值小于（比如）三，我需要删除整行

根据以下示例： A栏中有颜色列表，B栏中有名称。 如果我过滤了B列和A列中的任何“名称”，如果少于三个不同的值=true，则应删除整行

A         B
Color   Employee
Red     Dev
blue    Dev
blue    Dev
Red     Dev
black   Dev
Red     Dev
Red     Chary
blue    Chary
blue    Chary
Red     Chary
Red     Chary
Red     Chary

应删除名为-Chary的行

A         B
Color   Employee
Red     Dev
blue    Dev
blue    Dev
Red     Dev
black   Dev
Red     Dev
Red     Chary
blue    Chary
blue    Chary
Red     Chary
Red     Chary
Red     Chary

使用我的代码： 首先，我在B列中筛选名称，然后将筛选数据粘贴到新工作簿中，然后从A列中删除重复项，然后获得唯一计数。 如果唯一计数小于3，则激活主工作表并删除筛选的行并循环到下一个名称

莱斯特尚亚酒店 Application.ScreenUpdating=False Application.DisplayAlerts=False t=现在 设置wb=ActiveWorkbook SheetsVALID ARNS.激活 iCol=2'标准列 设置ws=SheetsVALID ARNS SheetsVALID ARNS.激活 设置rnglast=ColumnsiCol.Find*，Cells1，iCol，，xlByColumns，xlPrevious ws.ColumnsiCol.AdvancedFilter操作：=xlFilterInput，唯一：=True 设置rngUnique=RangeCells2，iCol，rnglast.SpecialCellsxlCellTypeVisible 工作手册。添加 设置newb=ActiveWorkbook 在恩古尼基的每一个大步 如果是strItem那么 ws.UsedRange.AutoFilter字段：=iCol，准则1:=strItem.Value 新手，启动 ws.UsedRange.SpecialCellsxlCellTypeVisible.Copy目标：=[A1] Application.CutCopyMode=False Cells.EntireColumn.AutoFit Dim uniq As范围 设置uniq=RangeA1:S&RangeA&Rows.Count.EndxlUp.Row uniq.removedupplicates列：=7，标题：=xlYes LastRow=ActiveSheet.UsedRange.Rows.Count 单元格。删除移位：=xlUp 范围A1.选择 wb.激活 如果LastRow<3，则 ActiveSheet.AutoFilter.Range.Offset1,0.Rows.SpecialCellsxlCellTypeVisible.Delete xlShiftUp 如果结束 如果结束 下一个 ws.ShowAllData MsgBox整个过程耗时！&FormatNow-t，hh:mm:ss和分钟 ActiveSheet.AutoFilterMode=False Application.ScreenUpdating=True Application.DisplayAlerts=True 端接头 我的代码在逐步调试模式下工作，但运行时会跳过很多行。 这是否与6000多行相关

---

在B列中过滤时，如何获得A列中不同值的计数？

这与您发布的代码不完全相同，因为我遇到了一些问题，但这里有一个替代解决方案。我只需将数据复制到另一张表中，请在运行我的代码之前添加名为“结果”的表，再添加两列公式，这些公式将检查是否应删除给定员工，筛选为“真”，然后删除相关行

从我测试的情况来看，这种解决方案似乎比应用高级过滤器、检查唯一值然后在整个数据集中循环更快。我希望它将为您的设置工作良好

代码如下：

Sub DeleteRows()
    Dim t As Variant
    Dim iCol As Long, lngLastRow As Long
    Dim wsOrig As Worksheet, wsNew As Worksheet

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    t = Now()
    Set wsOrig = Sheets("VALID ARNS")
    Set wsNew = Sheets("Results")
    iCol = 2 '### criteria column

    With wsOrig
        lngLastRow = .Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious).Row
        'copy into Results sheet
        .Range("A1:B" & lngLastRow).Copy wsNew.Range("A1")
        With wsNew
            'add formulas
            .Range("C1:D1").Value = VBA.Array("Instance", "Delete?")
            .Range("C2:C" & lngLastRow).Formula = "=COUNTIFS($A$2:A2,A2,$B$2:B2,B2)"
            .Range("D2:D" & lngLastRow).Formula = "=SUMIFS($C$2:$C$" & lngLastRow & ",$B$2:$B$" & lngLastRow & ",B2,$C$2:$C$" & lngLastRow & ",1)<3"
            'delete when column D = TRUE
            .Range("A1:D" & lngLastRow).AutoFilter Field:=4, Criteria1:="TRUE"
            .Range("D2:D" & lngLastRow).SpecialCells(xlCellTypeVisible).Rows.Delete
            'clear
            .Range("A1:B" & lngLastRow).AutoFilter
            .Range("C:D").Clear
        End With
    End With

    MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

---

嗨，Justyna MK，谢谢你的回复。你的代码太棒了，它工作得很好，非常感谢你的代码…如果有代码，请帮助我在过滤模式下在特定列中获得不同的值计数。。这只是为了我的知识，我在问。提前谢谢。很高兴它对你有用。当然，今天晚些时候我会尝试一下，并让您知道。看起来您无法使用筛选器或高级筛选器功能，因为您并不是真正在一列中查找唯一的值-实际上是a列和B列的组合决定了值是否唯一。这就是为什么您需要使用Scripting.Dictionary功能。我用一个函数getUnique更新了我的代码，该函数显示a列和B列的唯一组合，以及一个子例程CountUnique，该函数在调试模式下打印每个可见的过滤行的唯一组合数。希望能有帮助。