用vb进行条件排名

xqliao

又求助各位路过的大神伸援手了，想对下表数据进行条件排名，用数组公式如行数很多的话，计算很慢，想用vb代替公式，不知能否实现。感谢感谢！

姓名（A列)	本月出勤天数（B列）	本月出勤工时（C列）	本月业绩（D列）	业绩排名（E列）
张1	20	180	80	7
张2	22	200	85	6
张3	26	240	95	3
张4	26	250	100	1
张5	26	255	95	4
张6	26	250	93	5
张7	15	120	50
张8	28	270	100	2
张9	18	200	85
	B>=20	C>=180
说明：参与业绩排名需要(B>=20,C>=180)条件同时成立，用公式进行排名如行数较多就计算很慢，求用VB进行排名提高速度

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     .Range("e2:e" & r).ClearContents
   
9.     arr = .Range("a2:e" & r)
   
10.     For i = 1 To UBound(arr)
    
11.       If arr(i, 2) >= 20 And arr(i, 3) >= 180 Then
    
12.         d(arr(i, 4)) = d(arr(i, 4)) + 1
    
13.       End If
    
14.     Next
    
15.     nn = 1
    
16.     kk = d.keys
    
17.     For k = 0 To UBound(kk)
    
18.       mm = Application.Large(kk, k + 1)
    
19.       ss = d(mm)
    
20.       d(mm) = nn
    
21.       nn = nn + ss
    
22.     Next
    
23.     For i = 1 To UBound(arr)
    
24.       If arr(i, 2) >= 20 And arr(i, 3) >= 180 Then
    
25.         arr(i, 5) = d(arr(i, 4))
    
26.       End If
    
27.     Next
    
28.     .Range("a2:e" & r) = arr
    
29.   End With
    
30. End Sub
    

复制代码

chxw68

详见附件。

xqliao

chxw68 发表于 2018-8-19 16:32
详见附件。

谢谢chxw68老师！好感动！这么快就回复！问题ok了，太好啦！

xqliao

mikezhan 发表于 2018-8-19 17:18
业绩值相同的，排名相同。之后的排名将跳过。

Sub test()

谢谢mikezhan老师！

不知道为什么

chxw68 发表于 2018-8-19 16:31

褚老师，有段时间没怎么看到您了啊，近期都好把？

excelvlookup

如果成绩在1到100之间，就这样排，最简单
Sub test()
arr = Range("A2:d" & Cells(Rows.Count, 1).End(xlUp).Row)
ReDim brr(1 To 100, 1 To 2)
For i = 1 To UBound(arr)
    If arr(i, 2) >= 20 And arr(i, 3) >= 80 Then
        brr(arr(i, 4), 2) = brr(arr(i, 4), 2) & "|" & i
    End If
Next
n = 1
For i = 100 To 1 Step -1
    If brr(i, 2) <> "" Then
        s = Split(brr(i, 2), "|")
        For j = 1 To UBound(s)
            brr(Int(s(j)), 1) = n
        Next
        n = n + UBound(s)
    End If
Next
Sheet1.[f2].Resize(UBound(arr), 1) = brr
End Sub

chaohuahch

给一个不同的思路。

1. Sub fyExcelVBA()
   
2. Dim arr, brr, arr1, i&, j%, nRow%, nCol%, str$
   
3. Dim dic As Object
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. Set dic = CreateObject("scripting.dictionary")
   
7. With Sheets("sheet1")
   
8.     nRow = .Range("a" & Rows.Count).End(3).Row
   
9.     nCol = .Cells(1, Columns.Count).End(1).Column
   
10.     arr = .Range("a1").Resize(nRow, nCol - 1)
    
11.     brr = .Range(.Cells(1, nCol), .Cells(nRow, nCol))
    
12. End With
    
13. 
    
14. For i = 2 To UBound(arr)
    
15.     If arr(i, 2) < 20 Or arr(i, 3) < 180 Then
    
16.        For j = 1 To UBound(arr, 2)
    
17.            arr(i, j) = ""
    
18.        Next j
    
19.     End If
    
20. Next i
    
21. str = "中间转换"
    
22. Sheets.Add.Name = str
    
23. With Sheets(str).Range("a1").Resize(nRow, nCol - 1)
    
24.   .Value = arr
    
25.   .Sort key1:=.Cells(1, nCol - 1), order1:=xlDescending
    
26. End With
    
27. arr1 = Sheets(str).Range("a1").CurrentRegion
    
28. For i = 2 To UBound(arr1)
    
29.   n = n + 1
    
30.   dic(arr1(i, 1)) = n
    
31. Next i
    
32. 
    
33. For i = 2 To UBound(brr)
    
34.   If Not dic.exists(arr(i, 1)) Then
    
35.   brr(i, 1) = ""
    
36.   Else
    
37.   brr(i, 1) = dic(arr(i, 1))
    
38.   End If
    
39. Next i
    
40. With Sheets("sheet1")
    
41. .Range(.Cells(1, nCol), .Cells(nRow, nCol)) = brr
    
42. End With
    
43. Set dic = Nothing
    
44. Sheets(str).Delete
    
45. Application.ScreenUpdating = True
    
46. Application.DisplayAlerts = True
    
47. End Sub
    

复制代码

chxw68

不知道为什么 发表于 2018-8-19 19:56
褚老师，有段时间没怎么看到您了啊，近期都好把？

前段时间自驾游，谢谢你挂念。