求助下分数段人数统计问题，谢谢

lktqj

chxw68 发表于 2022-4-17 09:59
上面的代码用了字典，主要是考虑代码的适应性了。实际上可以不用字典，这样代码要简单一些。

学习了，感谢老师。

熊文来

chxw68 发表于 2022-4-16 23:22
来得少了。

最近工作比较多是吗？我留言给您了 也没见你回

chxw68

熊文来 发表于 2022-4-19 20:16
最近工作比较多是吗？我留言给您了 也没见你回

是这样的。

熊文来

chxw68 发表于 2022-4-19 20:27
是这样的。

工作繁忙页不要忘记休息。

chxw68

熊文来 发表于 2022-4-19 21:20
工作繁忙页不要忘记休息。

谢谢关心！

lktqj

chxw68 发表于 2022-4-17 09:59
上面的代码用了字典，主要是考虑代码的适应性了。实际上可以不用字典，这样代码要简单一些。

老师，今天我的一个帖子已经由“笨鸟飞不高”老师帮我解决了。能否请您出手，我想看看老师的思路，因为我今天在做这个表时想借用老师当时帮我写的分数段的代码，但是一直达不到想要的效果。不知道这样询问好不好，如果不能这样询问，还请移步https://club.excelhome.net/thread-1624549-1-1.html这个帖子。谢谢。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Set d1 = CreateObject("scripting.dictionary")
   
7.   With Worksheets("达标情况")
   
8.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
   
9.     arr = .Range("a2").Resize(2, c)
   
10.     ls = UBound(arr, 2)
    
11.     For j = 2 To UBound(arr, 2)
    
12.       If Len(arr(2, j)) <> 0 Then
    
13.         km = Left(arr(1, j), 1)
    
14.         If Not d1.exists(km) Then
    
15.           m = 1
    
16.           ReDim brr(1 To 2, 1 To m)
    
17.         Else
    
18.           brr = d1(km)
    
19.           m = UBound(brr, 2) + 1
    
20.           ReDim Preserve brr(1 To 2, 1 To m)
    
21.         End If
    
22.         brr(1, m) = arr(2, j)
    
23.         brr(2, m) = j
    
24.         d1(km) = brr
    
25.       End If
    
26.     Next
    
27.   End With
    
28.   With Worksheets("文科")
    
29.     .AutoFilterMode = False
    
30.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
31.     c = .Cells(2, .Columns.Count).End(xlToLeft).Column
    
32.     arr = .Range("a2").Resize(r - 1, c)
    
33.     For j = 5 To UBound(arr, 2)
    
34.       If arr(1, j) <> "年排" And arr(1, j) <> "班排" Then
    
35.         km = Left(arr(1, j), 1)
    
36.         If d1.exists(km) Then
    
37.           brr = d1(km)
    
38.           For i = 2 To UBound(arr)
    
39.             If Not d.exists(arr(i, 2)) Then
    
40.               ReDim crr(1 To ls)
    
41.               crr(1) = arr(i, 2)
    
42.             Else
    
43.               crr = d(arr(i, 2))
    
44.             End If
    
45.             For k = 1 To UBound(brr, 2)
    
46.               If arr(i, j) >= brr(1, k) Then
    
47.                 crr(brr(2, k)) = crr(brr(2, k)) + 1
    
48.               End If
    
49.             Next
    
50.             d(arr(i, 2)) = crr
    
51.           Next
    
52.         End If
    
53.       End If
    
54.     Next
    
55.   End With
    
56.   ReDim drr(1 To d.Count, 1 To ls)
    
57.   m = 0
    
58.   For Each aa In d.keys
    
59.     crr = d(aa)
    
60.     m = m + 1
    
61.     For j = 1 To UBound(crr)
    
62.       drr(m, j) = crr(j)
    
63.     Next
    
64.   Next
    
65.   With Worksheets("达标情况")
    
66.     .UsedRange.Offset(3, 0).Clear
    
67.     With .Range("a4").Resize(UBound(drr), UBound(drr, 2))
    
68.       .Value = drr
    
69.       .Borders.LineStyle = xlContinuous
    
70.       With .Font
    
71.         .Name = "微软雅黑"
    
72.         .Size = 10
    
73.         .Bold = False
    
74.       End With
    
75.       .Sort key1:=.Range("a4"), order1:=xlAscending, Header:=xlNo
    
76.     End With
    
77.     With .UsedRange
    
78.       .HorizontalAlignment = xlCenter
    
79.       .VerticalAlignment = xlCenter
    
80.     End With
    
81.   End With
    
82.   
    
83. End Sub
    

复制代码

chxw68

笨鸟飞不高老师写得非常好了。

lktqj

chxw68 发表于 2022-4-20 16:08
笨鸟飞不高老师写得非常好了。

感谢老师，把两位老师的对比着学习，再次感谢

lktqj

chxw68 发表于 2022-4-15 09:45
详见附件。

尊敬的chxw68老师，新年快乐！万事如意！
不好意思，想请教你点问题，等你有空再说也不急。
请你看看我的这个帖子，我想用AdvancedFilter，但是在查询条件那里输入姓名“张三”后，下方把所有名字里面含有张三的都显示出来了。我想只显示“张三”，不知如何修改了
帖子地址：https://club.excelhome.net/threa ... tml?_dsign=903179f6