[已解决]根据条件求名次

c888

根据条件求名次(VBA).rar (12.76 KB, 下载次数: 16)

2011-3-19 16:39 上传

点击文件名下载附件
能否将本表的函数求名次效果用（VBA）实现。原来VBA效果不要！谢谢大家指导。

最佳答案

月排行榜 / 总排行榜

mn860429

2011-3-19 17:49

1. Sub 统计()
   
2.     Dim Arr1, Arr2()
   
3.     Arr1 = Sheets("sheet1").Range("g4:K20")
   
4.     ReDim Arr2(1 To UBound(Arr1), 1 To 2)
   
5.     For i = 1 To UBound(Arr1)
   
6.         If IsEmpty(Cells(i + 3, "n")) And Arr1(i, 1) + Arr1(i, 2) + Arr1(i, 3) + Arr1(i, 4) + Arr1(i, 5) <> 0 Then
   
7.             Arr2(i, 1) = Arr1(i, 1) + Arr1(i, 2) + Arr1(i, 3) + Arr1(i, 4) + Arr1(i, 5)
   
8.             For k = 1 To UBound(Arr1)
   
9.                 If Arr1(k, 1) + Arr1(k, 2) + Arr1(k, 3) + Arr1(k, 4) + Arr1(k, 5) > Arr2(i, 1) _
   
10.                    And Cells(k + 3, "n") = "" _
    
11.                    And Arr1(i, 1) + Arr1(i, 2) + Arr1(i, 3) + Arr1(i, 4) + Arr1(i, 5) <> 0 Then
    
12.                     r = r + 1
    
13.                 End If
    
14.             Next k
    
15.             Arr2(i, 2) = r + 1
    
16.             r = 0
    
17.         End If
    
18.     Next i
    
19.     Sheets("sheet1").Range("v4").Resize(UBound(Arr1), 2).ClearContents
    
20.     Sheets("sheet1").Range("v4").Resize(UBound(Arr1), 2) = Arr2
    
21. End Sub

复制代码

跳转到最佳答案楼层

mn860429

1. Sub 统计()
   
2.     Dim Arr1, Arr2()
   
3.     Arr1 = Sheets("sheet1").Range("g4:K20")
   
4.     ReDim Arr2(1 To UBound(Arr1), 1 To 2)
   
5.     For i = 1 To UBound(Arr1)
   
6.         If IsEmpty(Cells(i + 3, "n")) And Arr1(i, 1) + Arr1(i, 2) + Arr1(i, 3) + Arr1(i, 4) + Arr1(i, 5) <> 0 Then
   
7.             Arr2(i, 1) = Arr1(i, 1) + Arr1(i, 2) + Arr1(i, 3) + Arr1(i, 4) + Arr1(i, 5)
   
8.             For k = 1 To UBound(Arr1)
   
9.                 If Arr1(k, 1) + Arr1(k, 2) + Arr1(k, 3) + Arr1(k, 4) + Arr1(k, 5) > Arr2(i, 1) _
   
10.                    And Cells(k + 3, "n") = "" _
    
11.                    And Arr1(i, 1) + Arr1(i, 2) + Arr1(i, 3) + Arr1(i, 4) + Arr1(i, 5) <> 0 Then
    
12.                     r = r + 1
    
13.                 End If
    
14.             Next k
    
15.             Arr2(i, 2) = r + 1
    
16.             r = 0
    
17.         End If
    
18.     Next i
    
19.     Sheets("sheet1").Range("v4").Resize(UBound(Arr1), 2).ClearContents
    
20.     Sheets("sheet1").Range("v4").Resize(UBound(Arr1), 2) = Arr2
    
21. End Sub

复制代码

sunjing-zxl

代码学习中