求助：用VBA字典法进行联合查找，引用数据后求取平均分

game178

是两个不同的类别，一个是语数英+文化科目，一个是语数英+技术科目

剑指E

你这手指一动，一伙人跟着你忙活大半天。

game178

字典法学了个一知半解

game178

感谢之前各位大大的热心帮助，不过因为自己之前没有表述清楚，高三那里没有区分，给大家添麻烦了。目前已经重新编辑，希望能继续得到各位大虾的关注和帮助，个人想来应该是联合变量字典法解决，但是字典法没有学到家，尴尬了。

game178

已经全面核查了数据设置，重新上传和编辑了表格，这次清晰的表述了目标意图，并做了预期的数据，期待你的关注和帮助。

game178

顶一下，求助，有好心人帮忙吗？顺便学习学习

game178

Sub 测试()

Application.ScreenUpdating = False '停止屏幕刷新
On Error Resume Next

Dim arr As Variant, i, j As Integer

With Sheets("班级赋分")
arow = .Cells(Rows.Count, 1).End(xlUp).Row '找到A列最后一个有数据单元格的行号
arr = Range("A2:aj" & arow) '把单元格区域装入数组

Set d = CreateObject("scripting.dictionary") '创建

For j = 4 To 14
    For i = 2 To UBound(arr, 1)  '遍历数组arr1的一维
   
        xm = arr(i, j)
        If xm = "" Then  '跳过空格
        Else
        Dim brr(200, 300)
            If Not d.exists(xm) Then
                d.Add xm, 1
                brr(d.Count - 1, 0) = arr(i, 1) & arr(i, 2) '年级班级
                brr(d.Count - 1, 1) = arr(i, j + 11) 'A
                brr(d.Count - 1, 2) = arr(i, j + 22) 'B
            Else
                d(xm) = d(xm) + 1
                cs = d(xm)
                brr(cs, (cs - 1) * 3 + 1) = arr(i, 1) & arr(i, 2) '年级班级
                brr(cs, (cs - 1) * 3 + 2) = arr(i, j + 11)  'A
                brr(cs, (cs - 1) * 3 + 3) = arr(i, j + 22)   'B
            End If
        End If
        
    Next
Next

End With

With Sheets("测试")
.[b2:c2000].ClearContents
.[b2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
.[c2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
.[f2].Resize(d.Count, 3) = brr
End With
Set d = Nothing '释放字典变量所占内存空间

Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

只能写入第一次，想把名字重复的3个数据依次写入brr中，怎么实现，主要是brr的一维卡起了，不能对应到相应的姓名处。

目前的设想是第一次出现在x行的0.1.2三列，第二次出现在x行的3.4.5,依次类推，最后显示出来

game178

Sub 测试()

Application.ScreenUpdating = False '停止屏幕刷新
On Error Resume Next

Dim arr As Variant, i, j As Integer

With Sheets("班级赋分")
arow = .Cells(Rows.Count, 1).End(xlUp).Row '找到A列最后一个有数据单元格的行号
arr = Range("A2:aj" & arow) '把单元格区域装入数组

Set d = CreateObject("scripting.dictionary") '创建

For j = 4 To 14
    For i = 2 To UBound(arr, 1)  '遍历数组arr1的一维
   
        xm = arr(i, j)
        If xm = "" Then  '跳过空格
        Else
        Dim brr(200, 300)
            If Not d.exists(xm) Then
                d.Add xm, 1
                brr(d.Count - 1, 0) = arr(i, 1) & arr(i, 2) '年级班级
                brr(d.Count - 1, 1) = arr(i, j + 11) 'A
                brr(d.Count - 1, 2) = arr(i, j + 22) 'B
            Else
                d(xm) = d(xm) + 1
                cs = d(xm)
                brr(cs, (cs - 1) * 3 + 1) = arr(i, 1) & arr(i, 2) '年级班级
                brr(cs, (cs - 1) * 3 + 2) = arr(i, j + 11)  'A
                brr(cs, (cs - 1) * 3 + 3) = arr(i, j + 22)   'B
            End If
        End If
        
    Next
Next

End With

With Sheets("测试")
.[b2:c2000].ClearContents
.[b2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
.[c2].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.items)
.[f2].Resize(d.Count, 3) = brr
End With
Set d = Nothing '释放字典变量所占内存空间

Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

chxw68

教师结果。参与一下。

game178

chxw68 发表于 2024-1-22 20:43
教师结果。参与一下。

非常感谢帮助的指导，受益了。   

For i = 2 To UBound(arr)
        For j = 4 To 14
            If Len(arr(i, j)) <> 0 Then '用长度去除空值
                If Not d.exists(arr(i, j)) Then
                    ReDim brr(1 To 59) '59有什么讲究吗？预留装重复数据用？
                    brr(1) = 6 '预留前面5个位置放置数据，从第6个数据开始3个一组，以便定位重复数据应该放置的位置
                    brr(2) = arr(i, j)
                Else
                    brr = d(arr(i, j))
                End If
                brr(3) = brr(3) + 1  '姓名出现次数累加，以便后面求平均值
                brr(4) = brr(4) + arr(i, j + 11) 'A值累加求和
                brr(5) = brr(5) + arr(i, j + 22) 'B值累加求和
               
                n = brr(1)
               
                brr(n) = arr(i, 1) & arr(i, 2) & arr(1, j) '年级班级科目
                brr(n + 1) = arr(i, j + 11) 'A值
                brr(n + 2) = arr(i, j + 22) 'B值
                n = n + 3
                brr(1) = n
                d(arr(i, j)) = brr  '将brr作为条目
            End If
        Next
    Next
   
这样理解应该没有错吧？如果怕出现次数过多，59也可以改成更大的数字，对吧？