修改代码

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5. arr = Sheet1.Range("a1").CurrentRegion.Value
   
6. For i = 2 To UBound(arr)
   
7.     s = arr(i, 2): s2 = arr(i, 3): s3 = arr(i, 4)
   
8.     If Not dic.Exists(s) Then Set dic(s) = CreateObject("scripting.dictionary")
   
9.     dic(s)(s2) = s3
   
10. Next
    
11. ReDim brr(1 To dic.Count, 1 To 5)
    
12. crr = [{"序号","姓名","语文","数学","英语"}]
    
13. For Each k In dic.Keys
    
14.     m = m + 1
    
15.     brr(m, 1) = m
    
16.     brr(m, 2) = k
    
17.     For j = 3 To 5
    
18.         brr(m, j) = dic(k)(crr(j))
    
19.     Next
    
20. Next
    
21. .Range("p10").Resize(1, 5) = crr
    
22. .Range("p11").Resize(m, 5) = brr
    
23. End With
    
24. Set dic = Nothing
    
25. Beep
    
26. End Sub
    
27. 
    

复制代码

Qs18

试试。。。。。。。

Qs18

试试。。。。。。

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Dim d As New Dictionary
    Dim brr(1 To 10000, 1 To 5)
    Dim Brow, Bcol
    Dim arr, x, k, kk, kkk
    With Sheet1
        arr = .Range("a2:d" & Range("a65536").End(xlUp).Row)
        For i = 1 To UBound(arr)
            s = arr(i, 2)
            If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
            ss = arr(i, 3)
            If Not d(s).Exists(ss) Then Set d(s)(ss) = CreateObject("scripting.dictionary")
            sss = arr(i, 4)
            d(s)(ss) = sss
        Next
        For Each k In d.Keys
            x = x + 1
            brr(x, 1) = x
            brr(x, 2) = k
            Key = d(k).Keys
            For Each kk In d(k).Keys
                If kk = "语文" Then
                    brr(x, 3) = d(k)(kk)
                ElseIf kk = "数学" Then
                    brr(x, 4) = d(k)(kk)
                Else
                    brr(x, 5) = d(k)(kk)
                End If
            Next
        Next
        .[p2].CurrentRegion.Offset(1) = Empty
        .[p2].Resize(x, 5) = brr
    End With
    Set d = Nothing
    Beep
End Sub

ddz79101

gwjkkkkk 发表于 2024-9-16 15:48
。。。。。。。。。。。。。

谢谢老师！运行成功！

ddz79101

jaxxcyh 发表于 2024-9-16 14:57

谢谢老师！运行成功

ddz79101

ykcbf1100 发表于 2024-9-16 16:21
全表自动生成，字典+数组

谢谢老师！运行成功！花后补

ddz79101

jaxxcyh 发表于 2024-9-16 16:32

谢谢老师！运行成功！花后补

ddz79101

Qs18 发表于 2024-9-16 16:45
试试。。。。。。

谢谢老师！运行成功！花后补！