基于VBA统计Sheet3中同姓名、月份、颜色的唯一BookID数量

核心逻辑 #

用**字典（Dictionary）**实现分组去重统计：

• 主字典以姓名|月份|颜色为唯一键，确保同一组合只统计一次
• 每个键对应一个子字典，用来存该组合下的唯一BookID（利用字典键的唯一性自动去重）
• 最后统计子字典的元素数量，就是该组合的唯一BookID总数

步骤1：准备工作（新手必看） #

打开VBA编辑器（Alt+F11），依次点击工具→引用，勾选Microsoft Scripting Runtime（方便直接使用Dictionary类型）。如果不想设置引用，可改用后期绑定（代码里会标注）。

步骤2：核心统计代码（Jack&Thomas一月专属） #

假设Sheet3的列对应关系：

• A列：BookID
• B列：Name
• C列：Month（格式为"1月"/"January"，可根据实际调整）
• D列：Color

Sub GetJanJackThomasStats()
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim mainDict As Dictionary ' 前期绑定，需勾选引用；后期绑定改As Object，用CreateObject创建
    Dim subDict As Dictionary
    Dim key As String
    Dim nameVal$, monthVal$, colorVal$, bookIDVal$
    
    ' 绑定Sheet3
    Set ws = ThisWorkbook.Sheets("Sheet3")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 获取数据最后一行
    
    ' 初始化主字典（后期绑定写法：Set mainDict = CreateObject("Scripting.Dictionary")）
    Set mainDict = New Dictionary
    mainDict.CompareMode = vbTextCompare ' 不区分大小写，可选
    
    ' 遍历数据行（跳过表头，从第2行开始）
    For i = 2 To lastRow
        nameVal = ws.Cells(i, "B").Value
        monthVal = ws.Cells(i, "C").Value
        colorVal = ws.Cells(i, "D").Value
        bookIDVal = ws.Cells(i, "A").Value
        
        ' 仅处理Jack、Thomas，且月份为一月
        If (nameVal = "Jack" Or nameVal = "Thomas") And monthVal = "1月" Then
            key = nameVal & "|" & monthVal & "|" & colorVal ' 生成组合键
            
            ' 组合键不存在则创建子字典
            If Not mainDict.Exists(key) Then
                Set subDict = New Dictionary
                subDict.CompareMode = vbTextCompare
                mainDict.Add key, subDict
            End If
            
            ' 子字典添加BookID（自动去重）
            If Not mainDict(key).Exists(bookIDVal) Then
                mainDict(key).Add bookIDVal, ""
            End If
        End If
    Next i
    
    ' 输出结果到立即窗口（Ctrl+G查看，方便调试）
    Debug.Print "=== Jack & Thomas 一月统计 ==="
    For Each key In mainDict.Keys
        Dim parts() As String
        parts = Split(key, "|")
        Debug.Print "姓名: " & parts(0) & " | 颜色: " & parts(2) & " | 唯一BookID数量: " & mainDict(key).Count
    Next key
    
    ' 将结果展示到表单
    ShowStatsOnForm mainDict
End Sub

步骤3：表单展示代码（标签/列表框二选一） #

假设你有一个名为frmBookStats的用户表单，包含：

• 静态标签lblStats（用于文本展示）
• 列表框lstStats（用于表格化展示）

Sub ShowStatsOnForm(statsDict As Dictionary)
    Dim frm As frmBookStats
    Dim key As String, parts() As String
    Dim statsText As String
    Dim totalDict As Dictionary ' 统计个人总计数
    
    Set frm = New frmBookStats
    Set totalDict = New Dictionary
    
    ' --------------------------
    ' 方式1：静态标签动态展示
    ' --------------------------
    statsText = "=== 一月图书统计结果 ===" & vbCrLf
    For Each key In statsDict.Keys
        parts = Split(key, "|")
        statsText = statsText & parts(0) & " - " & parts(2) & ": " & statsDict(key).Count & "本" & vbCrLf
    Next key
    frm.lblStats.Caption = statsText
    
    ' --------------------------
    ' 方式2：列表框表格化展示
    ' --------------------------
    With frm.lstStats
        .ColumnCount = 4
        .ColumnHeaders = True
        .ColumnWidths = "80,80,60,60" ' 列宽设置
        ' 添加表头
        .ListHeaders.Add , , "姓名"
        .ListHeaders.Add , , "颜色"
        .ListHeaders.Add , , "颜色计数"
        .ListHeaders.Add , , "个人总计数"
    End With
    
    ' 先统计每个人的总计数
    For Each key In statsDict.Keys
        parts = Split(key, "|")
        If Not totalDict.Exists(parts(0)) Then totalDict.Add parts(0), 0
        totalDict(parts(0)) = totalDict(parts(0)) + statsDict(key).Count
    Next key
    
    ' 添加列表项
    For Each key In statsDict.Keys
        parts = Split(key, "|")
        frm.lstStats.AddItem
        frm.lstStats.List(frm.lstStats.ListCount - 1, 0) = parts(0)
        frm.lstStats.List(frm.lstStats.ListCount - 1, 1) = parts(2)
        frm.lstStats.List(frm.lstStats.ListCount - 1, 2) = statsDict(key).Count
        frm.lstStats.List(frm.lstStats.ListCount - 1, 3) = totalDict(parts(0))
    Next key
    
    ' 显示表单
    frm.Show
End Sub

扩展到其他月份/人员的方法 #

把固定的姓名和月份改成参数，就能通用：

Sub GetStats(targetNames As Variant, targetMonth As String)
    Dim ws As Worksheet, lastRow As Long, i As Long
    Dim mainDict As Dictionary, subDict As Dictionary
    Dim key As String, nameVal$, monthVal$, colorVal$, bookIDVal$
    
    Set ws = ThisWorkbook.Sheets("Sheet3")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set mainDict = New Dictionary
    mainDict.CompareMode = vbTextCompare
    
    For i = 2 To lastRow
        nameVal = ws.Cells(i, "B").Value
        monthVal = ws.Cells(i, "C").Value
        colorVal = ws.Cells(i, "D").Value
        bookIDVal = ws.Cells(i, "A").Value
        
        ' 判断是否为目标人员和月份
        If UBound(Filter(targetNames, nameVal)) > -1 And monthVal = targetMonth Then
            key = nameVal & "|" & monthVal & "|" & colorVal
            If Not mainDict.Exists(key) Then
                Set subDict = New Dictionary
                mainDict.Add key, subDict
            End If
            If Not mainDict(key).Exists(bookIDVal) Then
                mainDict(key).Add bookIDVal, ""
            End If
        End If
    Next i
    
    ' 调用展示函数
    ShowStatsOnForm mainDict
End Sub

' 调用示例：统计Amy和Bob的二月数据
' Call GetStats(Array("Amy", "Bob"), "2月")

新手注意事项 #

1. 列号调整：代码中Cells(i, "X")的字母要对应你Sheet3的实际列（比如Name在E列就改成"E"）
2. Month格式：如果Sheet里的Month是数字（如1），把monthVal = "1月"改成monthVal = 1
3. 字典绑定：如果没勾选引用，把Dim mainDict As Dictionary改成Dim mainDict As Object，并替换Set mainDict = New Dictionary为Set mainDict = CreateObject("Scripting.Dictionary")

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