使用嵌套字典统计每日测试次数的VBA代码问题求助

原始数据集（每行代表一次测试） #

期望统计输出 #

尝试的嵌套字典实现代码（运行结果不符合预期） #

Option Explicit
Private Sub btnTestTracker_Click()

'DELERATIONS
Dim datarows As Long
Dim rngResults As Range
Dim dicdate As Object
Dim dictester As Object
Dim arrData As Variant
Dim arrTester() As Variant
Dim arrDate() As Variant
Dim idxRow As Long
Dim ky1, ky2 As Variant
Dim lastrow As Integer

Dim data As Worksheet
Set data = ThisWorkbook.Worksheets("Data Transfer")

'GET NUMBER OF ROWS TO SEARCH
datarows = data.UsedRange.Rows.Count

'BUILD DATA SET
arrData = data.Range("a6:co" & datarows)

Set dictester = CreateObject("Scripting.Dictionary")
Set dicdate = CreateObject("Scripting.Dictionary")

For idxRow = 1 To UBound(arrData, 1)
    ky1 = arrData(idxRow, 18)
    ky2 = arrData(idxRow, 20)
    
    If dicdate.Exists(ky1) Then
        
        arrDate = dicdate(ky1) ' SELECT DATE ARRAY FOR KY1
        
        If dictester.Exists(ky2) Then
            arrTester = dictester(ky2) ' SELECT TESTER ARRAY FOR KY2
            arrTester(0) = arrTester(0) + 1 'ADD TEST FOR KY2
            arrDate(1) = dictester(ky2) 'ADD TESTER + COUNT TO DATE DICT
        Else
            arrTester = Array(1) 'CREATE TESTER ARRAY FOR KY2
            arrDate(1) = dictester(ky2) 'ADD TESTER + COUNT TO DATE DICT
        End If
        
    Else
        If dictester.Exists(ky2) Then
            arrTester = dictester(ky2) ' SELECT TESTER ARRAY FOR KY2
            arrTester(0) = arrTester(0) + 1 'ADD TEST FOR KY2
        Else
            arrTester = Array(1) 'CREATE TESTER ARRAY FOR KY2
        End If
          arrDate = Array(1, dictester(ky2)) 'CREATE DATE ARRAY FOR KY1
        
    End If
    
    dictester(ky2) = arrTester
    dicdate(ky1) = arrDate
    
Next idxRow

'RECORD RESULTS
lastrow = ThisWorkbook.Worksheets("Test Tracker").Cells(Rows.Count, 1).End(xlUp).row
Set rngResults = ThisWorkbook.Worksheets("Test Tracker").Range("a" & lastrow + 1)

For Each ky1 In dicdate.Keys
    rngResults.Offset(, 0) = ky1
    For Each dictester In dicdate.Keys
        rngResults.Offset(, 1) = ky2
        rngResults.Offset(, 2) = dictester(ky2)(0)
        Set rngResults = rngResults.Offset(1)
    Next dictester
    Set rngResults = rngResults.Offset(1)
Next ky1
End Sub

错误输出结果 #

原代码核心问题：

• 错误使用全局字典存储所有技术人员的测试次数，未按日期隔离，导致跨日期累加
• 输出循环逻辑混乱，变量引用错误，导致结果格式和数据错误

修正后的嵌套字典代码 #

Option Explicit
Private Sub btnTestTracker_Click()
    Dim wsData As Worksheet, wsTracker As Worksheet
    Dim arrData As Variant
    Dim dateDict As Object ' 外层字典：键=日期，值=内层字典（键=技术人员，值=测试次数）
    Dim testerDict As Object
    Dim idxRow As Long
    Dim currentDate As Variant, currentTech As Variant
    Dim lastRow As Long
    Dim rngOutput As Range
    Dim dateKey As Variant, techKey As Variant
    
    ' 初始化工作表对象
    Set wsData = ThisWorkbook.Worksheets("Data Transfer")
    Set wsTracker = ThisWorkbook.Worksheets("Test Tracker")
    Set dateDict = CreateObject("Scripting.Dictionary")
    
    ' 读取数据到数组（高效处理大数据集）
    arrData = wsData.Range("A6:CO" & wsData.UsedRange.Rows.Count).Value
    
    ' 遍历数据统计次数
    For idxRow = 1 To UBound(arrData, 1)
        currentDate = arrData(idxRow, 18) ' 第18列对应日期
        currentTech = arrData(idxRow, 20) ' 第20列对应技术人员
        
        ' 跳过空值行
        If currentDate <> "" And currentTech <> "" Then
            ' 日期不存在则创建新的内层字典
            If Not dateDict.Exists(currentDate) Then
                Set testerDict = CreateObject("Scripting.Dictionary")
                dateDict.Add currentDate, testerDict
            Else
                Set testerDict = dateDict(currentDate)
            End If
            
            ' 统计该技术人员当日测试次数
            If testerDict.Exists(currentTech) Then
                testerDict(currentTech) = testerDict(currentTech) + 1
            Else
                testerDict.Add currentTech, 1
            End If
        End If
    Next idxRow
    
    ' 准备输出位置
    lastRow = wsTracker.Cells(wsTracker.Rows.Count, 1).End(xlUp).Row
    Set rngOutput = wsTracker.Range("A" & lastRow + 1)
    
    ' 输出统计结果
    For Each dateKey In dateDict.Keys
        Set testerDict = dateDict(dateKey)
        For Each techKey In testerDict.Keys
            rngOutput.Value = dateKey
            rngOutput.Offset(0, 1).Value = techKey
            rngOutput.Offset(0, 2).Value = testerDict(techKey)
            Set rngOutput = rngOutput.Offset(1, 0)
        Next techKey
    Next dateKey
    
    ' 释放对象
    Set testerDict = Nothing
    Set dateDict = Nothing
    Set wsData = Nothing
    Set wsTracker = Nothing
End Sub

更优方案：Power Query（适合大规模数据集） #

对于大数据集，Power Query性能更稳定且无需编写复杂VBA：

1. 打开Data Transfer工作表，选中目标数据区域（含表头）
2. 点击数据选项卡 → 从表格/区域（Excel 2016及以上版本）
3. 在Power Query编辑器中：
   • 选中date和Tech对应的列（原数据第18、20列）
   • 点击转换选项卡 → 分组依据
   • 分组依据选择date和Tech，新列名设为# of Tests，操作选择行数
4. 点击关闭并上载，将结果加载到Test Tracker工作表或指定位置

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