字典法计数

凌飞云天

想 用字典的方法算出A列16个班每班分数在100以上；90-99.5；70-89.5；50-69.5的人数，并分别在D、E、F、G列显示。程序运行后什么也没出现。不知问题出在哪儿？求高手指点。

shiruiqiang

大致按照你的思路写了一下

新手路过

fzxba

Sub test0() '班级有序，可不用字典
  Dim ar, br(), i As Long, j As Long, k As Long, s As String
  ar = Sheet1.Range("A1").CurrentRegion.Resize(, 2).Value
  ReDim br(1 To UBound(ar), 1 To 6)
  For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> s Then
      s = Trim(ar(i, 1))
      k = k + 1
      br(k, 1) = s
    End If
    Select Case Val(ar(i, 2))
      Case Is >= 100
        j = 2
      Case 90 To 99.9
        j = 3
      Case 70 To 89.9
        j = 4
      Case 50 To 69.9
        j = 5
'      Case Else
'        j = 6
    End Select
    br(k, j) = br(k, j) + 1
  Next
  Sheet1.Range("C2").Resize(UBound(br), UBound(br, 2)) = br
End Sub

半百

这样吗？

无关岁月

副本字典法计数.7z (26.22 KB, 下载次数: 13)

2024-2-27 20:11 上传

点击文件名下载附件

chxw68

修改的楼主代码。

清风竹-

请看附件。

ykcbf1100

参与一下。。。

ykcbf1100

代码供参考。。。

1. Sub ykcbf()  '//2024.2.27
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     arr = Sheets("分数").UsedRange
   
6.     Cells.Interior.ColorIndex = 0
   
7.     ReDim brr(1 To UBound(arr), 1 To 5)
   
8.     m = 1: n = 3: brr(m, 1) = "班级"
   
9.     brr(m, 2) = "特": brr(m, 3) = "优": brr(m, 4) = "良": brr(m, 5) = "格"
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 1)
    
12.         If arr(i, 2) > 0 Then
    
13.             If Not d.exists(s) Then
    
14.                 m = m + 1
    
15.                 d(s) = m
    
16.                 brr(m, 1) = arr(i, 1)
    
17.             End If
    
18.             r = d(arr(i, 1))
    
19.             Select Case arr(i, 2)
    
20.                 Case Is >= 100
    
21.                     brr(r, 2) = brr(r, 2) + 1
    
22.                 Case Is >= 90
    
23.                     brr(r, 3) = brr(r, 3) + 1
    
24.                 Case Is >= 70
    
25.                     brr(r, 4) = brr(r, 4) + 1
    
26.                 Case Else
    
27.                     brr(r, 5) = brr(r, 5) + 1
    
28.             End Select
    
29.         End If
    
30.     Next
    
31.     With [c1].Resize(m, 5)
    
32.         .Value = brr
    
33.         .Borders.LineStyle = 1
    
34.         .HorizontalAlignment = xlCenter
    
35.         .VerticalAlignment = xlCenter
    
36.     End With
    
37.     [c1].Resize(1, 5).Interior.Color = 49407
    
38.     Set d = Nothing
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub TEST9()
    Dim ar, i&, j&, r&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    ar = [A1].CurrentRegion
   
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then
            Set dic(ar(i, 1)) = CreateObject("Scripting.Dictionary")
        End If
        Select Case ar(i, 2)
            Case Is >= 100
            dic(ar(i, 1))(2) = dic(ar(i, 1))(2) + 1
            Case Is >= 90
            dic(ar(i, 1))(3) = dic(ar(i, 1))(3) + 1
            Case Is >= 70
            dic(ar(i, 1))(4) = dic(ar(i, 1))(4) + 1
            Case Is >= 50
            dic(ar(i, 1))(5) = dic(ar(i, 1))(5) + 1
        End Select
    Next i
   
    ReDim ar(1 To dic.Count, 1 To 5)
    For Each vKey In dic.keys
        r = r + 1
        ar(r, 1) = vKey
        For j = 2 To 5
            If dic(vKey).exists(j) Then
                ar(r, j) = dic(vKey)(j)
            End If
        Next j
    Next
   
    [L2].Resize(UBound(ar), 5) = ar
    Set dic = Nothing
    Application.ScreenUpdating = True
End Sub