[已解决]用VBA加一个判断

long826121

首先非常感谢各位兄弟姐妹，大家晚上好。
由于原来没有考虑周全，所以想请教各位一个问题：
要求是：当“分数”这一列全部为空时，“名次（这一列）“、前五名、前十名、倒五名、倒十名”、“平均分、分差”下面的单元格全为空。【需要加这个判断】
第一阶段月考.rar (11.06 KB, 下载次数: 11)

2014-5-11 21:07 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

zjdh

2014-5-15 08:29

第一阶段月考.rar (10.94 KB, 下载次数: 10)

2014-5-15 08:35 上传

点击文件名下载附件

跳转到最佳答案楼层

FnG

代码可以加在最前面

1. If [b65536].End(3).Row = 1 Then Exit Sub

复制代码

dsmch

第一句添加：

1.    If Application.CountA(Columns(2)) = 1 Then Exit Sub
   

复制代码

FnG

上面代码无法清除原有的非空数据，下面的加了清除数据功能

1.     If [b65536].End(3).Row = 1 Then
   
2.         Union([g2], [h2], [k2], [l2], [g7], [h7], [k7], [l7], [g12], [h12], [g15]).ClearContents
   
3.         Exit Sub
   
4.     End If
   

复制代码

其实你这代码这样改了还是问题多多，如果有分数但只有几个人的话还是有可能会出错，而且代码效率也不高，建议你让dsmch老师给你重新写一个。

long826121

dsmch 发表于 2014-5-11 21:15
第一句添加：

dsmch老师可以重新帮我写一下这个程序不？非常感谢老师

dsmch

写这样的代码没啥意义，不小心着了2楼的道了

1. Sub Macro1()
   
2. Dim arr, d, d2, i&, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. Union([g2], [h2], [k2], [l2], [g7], [h7], [k7], [l7], [g12], [h12], [g15]).ClearContents
   
6. If Application.CountA(Columns(2)) = 1 Then Exit Sub
   
7. Range("a1").CurrentRegion.Sort [b2], Order1:=xlDescending, Header:=xlGuess
   
8. arr = Range("a1").CurrentRegion
   
9. n = UBound(arr)
   
10. For i = 2 To n
    
11.     d2(arr(i, 3)) = d2(arr(i, 3)) + arr(i, 2)
    
12.     d(arr(i, 3)) = d(arr(i, 3)) + 1
    
13.     If i = 6 Then [g2] = d(1): [h2] = d(2)
    
14.     If i = 11 Then [k2] = d(1): [l2] = d(2)
    
15.     If i = n - 10 Then x1 = d(1): x2 = d(2)
    
16.     If i = n - 5 Then y1 = d(1): y2 = d(2)
    
17. Next
    
18. [g7] = d(1) - y1: [h7] = d(2) - y2
    
19. [k7] = d(1) - x1: [l7] = d(2) - x2
    
20. [g12] = Application.Round(d2(1) / d(1), 2)
    
21. [h12] = Application.Round(d2(2) / d(2), 2)
    
22. [g15] = Abs([g12] - [h12])
    
23. End Sub
    

复制代码

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, d2, i&, s&, j&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. [h:z].ClearContents
   
6. If Application.CountA([b:b]) = 1 Then Exit Sub
   
7. Range("a1").CurrentRegion.Sort [b2], Order1:=xlDescending, Header:=xlGuess
   
8. arr = Range("a1").CurrentRegion
   
9. ReDim crr(1 To UBound(arr) - 1, 1 To 1)
   
10. For i = 2 To UBound(arr)
    
11.      d2(arr(i, 3)) = d2(arr(i, 3)) + 1
    
12.     If Not d.exists(arr(i, 2)) Then
    
13.         s = s + 1
    
14.         d(arr(i, 2)) = s
    
15.         crr(i - 1, 1) = s
    
16.     Else
    
17.         crr(i - 1, 1) = d(arr(i, 2))
    
18.     End If
    
19. Next
    
20. ReDim brr(1 To 6, 1 To d2.Count)
    
21. a = d.keys: b = d2.keys: c = d2.items
    
22. For j = 0 To d2.Count - 1
    
23.     brr(1, j + 1) = b(j)
    
24.     For i = 2 To UBound(arr)
    
25.         If arr(i, 3) = b(j) Then brr(6, j + 1) = brr(6, j + 1) + arr(i, 2)
    
26.         If arr(i, 2) >= a(4) And arr(i, 3) = b(j) Then brr(2, j + 1) = brr(2, j + 1) + 1
    
27.         If arr(i, 2) >= a(9) And arr(i, 3) = b(j) Then brr(3, j + 1) = brr(3, j + 1) + 1
    
28.         If arr(i, 2) <= a(d.Count - 5) And arr(i, 3) = b(j) Then brr(4, j + 1) = brr(4, j + 1) + 1
    
29.         If arr(i, 2) <= a(d.Count - 10) And arr(i, 3) = b(j) Then brr(5, j + 1) = brr(5, j + 1) + 1
    
30.     Next
    
31.     brr(6, j + 1) = Round(brr(6, j + 1) / c(j), 2)
    
32. Next
    
33. Range("d2").Resize(UBound(crr)) = crr
    
34. Range("h1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
35. End Sub
    

复制代码

dsmch

为增加代码的通用性，代码自动生成组别（适用多组别），结果布局做了调整

long826121

dsmch 发表于 2014-5-12 20:35
为增加代码的通用性，代码自动生成组别（适用多组别），结果布局做了调整

具体要求里面有！非常感谢！ 第一阶段月考.rar (13.07 KB, 下载次数: 4)

2014-5-13 22:28 上传

点击文件名下载附件

zjdh

第一阶段月考.rar (10.94 KB, 下载次数: 10)

2014-5-15 08:35 上传

点击文件名下载附件