如何让VBA中Application.WorksheetFunction.CountIf仅统计可见单元格

我正在跟踪每位操作员每周（含过去5周）的缺陷数据：从顶部数据表提取唯一员工姓名至T列，随后按员工姓名筛选数据，仅需复制粘贴当前周（由weekNumber变量存储，当前值为41）存在缺陷的员工数据。现有VBA代码存在以下问题：

• Application.WorksheetFunction.CountIf会统计筛选后的隐藏单元格，导致所有员工数据都被复制粘贴；
• 尝试将统计范围改为SpecialCells(xlCellTypeVisible)时，触发运行时错误1004：无法获取WorksheetFunction类的CountIf属性。

原代码 #

Sub FilterEASouthEve()
   Dim ws As Worksheet
   Dim tbl As ListObject
   Dim tbl2 As ListObject
   Dim rng As Range, cell As Range, cell2 As Range
   Dim rngT As Range
   Dim rngN As Range
   Dim filteredData As Range
   Dim destRange As Range
   Dim lastRowN As Long
   Dim lastRowT As Long
   Dim filterValue As Variant
   Dim rngWeek6 As Range
   Dim weekNumber As Integer
    
    'gets week number from first sheet to store in variable
    Sheets("All1700Defects").Select
    weekNumber = Range("S22").Value

    'creates table from data on EAS Eve sheet
    Sheets("EA SOUTH - EVE").Select
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("a1", Cells(Range("a1000000").End(xlUp).Row, "Q:Q")), , xlYes).Name = _
        "Table65"
    Range("Table65[#All]").Select
    ActiveSheet.ListObjects("Table65").Name = "EASouthEve"

   ' Set the worksheet and table
   Set ws = ThisWorkbook.Sheets("EA SOUTH - EVE")
   Set tbl = ws.ListObjects("EASouthEve")

   ' Define the range for Col T (unique employee names), which is used as criteria for filtering the table by employee name
   Set rngT = ws.Range("T2:T" & ws.Cells(Rows.Count, "T").End(xlUp).Row)

    'loop thru each cell in Column T, starting at T2
    For Each cell In rngT
    
        'check if the cell is not empty
        If Not IsEmpty(cell) Then
            
            'get value to filter by
            filterValue = cell.Value
    
        
            ' Apply the filter
            tbl.Range.AutoFilter Field:=14, Criteria1:=filterValue, Operator:=xlFilterValues
            
            'set range for Week column
            Set rngWeek6 = ws.Range("I2", Selection.End(xlDown))
         
            ' Determine the destination range
            lastRowN = ws.Cells(Rows.Count, "N").End(xlUp).Row
            Set destRange = ws.Cells(lastRowN + 20, "A")
         
            'determines if employee has any defects in current week
            If Application.WorksheetFunction.CountIf(rngWeek6, weekNumber) > 0 Then
            
                ' Paste the filtered data below the table with 10-row separation
                Range("EASouthEve[[#Headers],[Date]]").Select
                 Range(Selection, Selection.End(xlDown)).Select
                 Range(Selection, Selection.End(xlToRight)).Select
                 Selection.Copy
                destRange.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                
                Set rng = Selection
                
                Set tbl2 = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
                
                MakePivotTableFromSelection
            End If
        End If
    Next cell
    
    'turn table filters off
    ActiveSheet.ListObjects("EASOUTHEve").Range.AutoFilter Field:=14
    
    Columns("A:A").Select
    Selection.NumberFormat = "m/d/yyyy"
    Columns("O:O").Select
    Selection.NumberFormat = "m/d/yyyy"
    Columns("P:P").Select
    Selection.NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
    Range("A1").Select
    Selection.End(xlDown).Select
  
End Sub

尝试修改的代码片段 #

Set rngWeek6 = ws.Range("I2", Selection.End(xlDown)).SpecialCells(xlCellTypeVisible)

核心问题 #

CountIf函数无法直接处理SpecialCells(xlCellTypeVisible)返回的非连续单元格区域，这是触发1004错误的根本原因。同时原代码依赖Select/Selection的方式容易导致范围引用混乱，且未正确区分可见单元格。

修正方案 #

1. 替换CountIf，改用SUMPRODUCT+SUBTOTAL统计可见单元格
   使用SUMPRODUCT结合SUBTOTAL函数可以实现对可见单元格的条件计数，无需循环，效率更高：

   Dim count As Long
   count = Application.SUMPRODUCT(SUBTOTAL(103, OFFSET(tbl.ListColumns("Week").DataBodyRange, ROW(tbl.ListColumns("Week").DataBodyRange) - MIN(ROW(tbl.ListColumns("Week").DataBodyRange)), 0, 1)), --(tbl.ListColumns("Week").DataBodyRange = weekNumber))
   

   其中SUBTOTAL(103,...)用于判断单元格是否可见，--(...)将布尔值转为0/1，最终求和得到符合条件的可见单元格数量。

2. 移除所有Select/Selection操作
   直接通过ListObject对象引用数据范围，避免手动选择带来的错误，例如将获取Week列范围改为：

   Set rngWeek6 = tbl.ListColumns("Week").DataBodyRange
   

3. 直接获取筛选后的可见数据范围
   筛选完成后，通过tbl.DataBodyRange.SpecialCells(xlCellTypeVisible)获取可见数据，无需手动选择整行整列。

完整修正代码 #

Sub FilterEASouthEve()
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim tbl2 As ListObject
    Dim rngT As Range, cell As Range
    Dim destRange As Range
    Dim lastRow As Long
    Dim filterValue As Variant
    Dim weekNumber As Integer
    Dim visibleCount As Long
    
    ' 获取周数（避免Select）
    Set ws = ThisWorkbook.Sheets("All1700Defects")
    weekNumber = ws.Range("S22").Value
    Set ws = ThisWorkbook.Sheets("EA SOUTH - EVE")
    
    ' 检查表是否已存在，避免重复创建
    On Error Resume Next
    Set tbl = ws.ListObjects("EASouthEve")
    On Error GoTo 0
    If tbl Is Nothing Then
        ' 创建表格（无需Select）
        Dim dataRange As Range
        Set dataRange = ws.Range("A1:Q" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
        Set tbl = ws.ListObjects.Add(xlSrcRange, dataRange, , xlYes)
        tbl.Name = "EASouthEve"
    End If
    
    ' 定义唯一员工姓名范围
    Set rngT = ws.Range("T2:T" & ws.Cells(ws.Rows.Count, "T").End(xlUp).Row)
    
    ' 遍历每个员工
    For Each cell In rngT
        If Not IsEmpty(cell) Then
            filterValue = cell.Value
            
            ' 应用筛选
            tbl.Range.AutoFilter Field:=14, Criteria1:=filterValue
            
            ' 统计当前员工本周的可见缺陷数
            visibleCount = Application.SUMPRODUCT( _
                Application.Subtotal(103, Application.Offset(tbl.ListColumns("Week").DataBodyRange, _
                ROW(tbl.ListColumns("Week").DataBodyRange) - MIN(ROW(tbl.ListColumns("Week").DataBodyRange)), 0, 1)), _
                --(tbl.ListColumns("Week").DataBodyRange = weekNumber) _
            )
            
            If visibleCount > 0 Then
                ' 获取目标粘贴位置（向下偏移20行）
                lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
                Set destRange = ws.Cells(lastRow + 20, "A")
                
                ' 复制可见数据（含表头）
                tbl.Range.SpecialCells(xlCellTypeVisible).Copy
                destRange.PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                
                ' 新建表格并生成透视表
                Dim newTblRange As Range
                Set newTblRange = ws.Range(destRange, destRange.End(xlDown).End(xlToRight))
                Set tbl2 = ws.ListObjects.Add(xlSrcRange, newTblRange, , xlYes)
                MakePivotTableFromSelection
            End If
            
            ' 清除当前筛选
            tbl.Range.AutoFilter Field:=14
        End If
    Next cell
    
    ' 统一设置格式（无需Select）
    ws.Columns("A:A").NumberFormat = "m/d/yyyy"
    ws.Columns("O:O").NumberFormat = "m/d/yyyy"
    ws.Columns("P:P").NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
    
    ' 定位到数据末尾
    ws.Cells(ws.Rows.Count, "A").End(xlUp).Select
End Sub

额外优化点 #

• 添加了表格存在性检查，避免重复创建表格导致错误；
• 所有范围引用均通过对象直接获取，彻底移除Select/Selection；
• 筛选后自动清除当前员工的筛选，避免影响下一次循环。

内容的提问来源于stack exchange，提问作者Caid Franks