VBA简化统计各Studyboard学生数并转至Statistics工作表求助

嘿，我完全懂你这种写一堆重复CountIf代码的痛苦——不仅冗长，后续要是Studyboard编号变了还得改代码，太麻烦了！下面给你两种更高效灵活的方案，都能自动把统计结果输出到新建的Statistics工作表里，彻底告别重复代码～

方法一：用字典（Dictionary）高效统计（推荐） #

字典是VBA里处理这类“键值对统计”的神器，不管H列有多少个不同的Studyboard编号，都能自动遍历统计，代码简洁还高效，尤其适合你这种上万行的数据量。

Sub CountStudentsWithDictionary()
    Dim wsSource As Worksheet
    Dim wsStats As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim cell As Range
    Dim countDict As Object
    Dim key As Variant
    Dim outputRow As Long
    
    ' 关闭屏幕更新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 定义源工作表（这里默认当前活动表，可改成具体表名如Sheet1）
    Set wsSource = ActiveSheet
    
    ' 检查并创建Statistics工作表
    On Error Resume Next
    Set wsStats = ThisWorkbook.Worksheets("Statistics")
    If Err.Number <> 0 Then
        Set wsStats = ThisWorkbook.Worksheets.Add
        wsStats.Name = "Statistics"
    End If
    On Error GoTo 0
    
    ' 清空Statistics表原有内容（可选，按需调整）
    wsStats.Cells.Clear
    
    ' 自动获取H列最后一行行号，不用硬写18288
    lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
    Set dataRange = wsSource.Range("H2:H" & lastRow)
    
    ' 初始化字典
    Set countDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历H列数据，统计每个Studyboard的出现次数
    For Each cell In dataRange
        If Not cell.Value = "" Then ' 跳过空单元格
            If countDict.Exists(cell.Value) Then
                countDict(cell.Value) = countDict(cell.Value) + 1
            Else
                countDict(cell.Value) = 1
            End If
        End If
    Next cell
    
    ' 输出统计结果到Statistics工作表
    wsStats.Range("A1").Value = "Studyboard编号"
    wsStats.Range("B1").Value = "学生数量"
    outputRow = 2
    
    For Each key In countDict.Keys
        wsStats.Cells(outputRow, "A").Value = key
        wsStats.Cells(outputRow, "B").Value = countDict(key)
        outputRow = outputRow + 1
    Next key
    
    ' 自动调整列宽，让排版更美观
    wsStats.Columns("A:B").AutoFit
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    MsgBox "统计完成！结果已保存到Statistics工作表。"
End Sub

代码优势： #

• 自动识别H列所有非空的Studyboard编号，不用手动指定每个编号
• 处理上万行数据的速度比逐个写CountIf快很多
• 自动创建/复用Statistics工作表，结果排版更规范

方法二：用RemoveDuplicates+批量CountIf公式 #

如果你更习惯用工作表函数的思路，也可以先提取H列的唯一编号，再批量生成CountIf公式，不用手动写每个编号的统计：

Sub CountStudentsWithFormula()
    Dim wsSource As Worksheet
    Dim wsStats As Worksheet
    Dim lastRow As Long
    Dim uniqueRange As Range
    
    Application.ScreenUpdating = False
    
    Set wsSource = ActiveSheet
    
    ' 检查并创建Statistics工作表
    On Error Resume Next
    Set wsStats = ThisWorkbook.Worksheets("Statistics")
    If Err.Number <> 0 Then
        Set wsStats = ThisWorkbook.Worksheets.Add
        wsStats.Name = "Statistics"
    End If
    On Error GoTo 0
    
    wsStats.Cells.Clear
    
    ' 复制H列数据到Statistics表，提取唯一值
    lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
    wsSource.Range("H2:H" & lastRow).Copy wsStats.Range("A2")
    wsStats.Range("A2:A" & lastRow).RemoveDuplicates Columns:=1, Header:=xlNo
    
    ' 写入表头
    wsStats.Range("A1").Value = "Studyboard编号"
    wsStats.Range("B1").Value = "学生数量"
    
    ' 批量生成CountIf公式
    lastRow = wsStats.Cells(wsStats.Rows.Count, "A").End(xlUp).Row
    wsStats.Range("B2:B" & lastRow).Formula = _
        "=COUNTIF('" & wsSource.Name & "'!H:H, A2)"
    
    ' 可选：把公式转成值，避免源数据变动影响统计结果
    wsStats.Range("B2:B" & lastRow).Value = wsStats.Range("B2:B" & lastRow).Value
    
    wsStats.Columns("A:B").AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "统计完成！"
End Sub

代码优势： #

• 利用工作表函数的特性，代码逻辑简单易懂
• 同样不用手动指定每个编号，自动适配H列的所有不同值

这两种方法都能完美替代你原来冗长的CountIf代码，选哪个看你个人习惯～

内容的提问来源于stack exchange，提问作者Chris TJ