用vb进行条件排名

chaohuahch

用数据库的方法也做了一下，发现运行时间比较慢。

1. Sub fyExcelVBACon()
   
2. Dim arr, brr, arr1, i&, j%, nRow%, nCol%, str$
   
3. Dim dic As Object
   
4. Dim cnn, SQL$   '定义数据库连接和SQL语句
   
5. t = Timer
   
6. Application.ScreenUpdating = False
   
7. Application.DisplayAlerts = False
   
8. '---------------------------------------   SQL结果处理  ------------------- ------------------- -------------------
   
9. With Sheets("sheet1")
   
10.     nRow = .Range("a" & Rows.Count).End(3).Row
    
11.     nCol = .Cells(1, Columns.Count).End(1).Column
    
12.     arr = .Range("a1").Resize(nRow, nCol - 1)
    
13.     brr = .Range(.Cells(1, nCol), .Cells(nRow, nCol))
    
14. End With
    
15. '---------------------------------------  设置数据库连接   ------------------- ------------------- -------------------
    
16. Set dic = CreateObject("scripting.dictionary")
    
17. Set cnn = CreateObject("adodb.connection")  '创建数据库连接
    
18. Set rs = CreateObject("adodb.recordset")   '创建一个数据集保存数据
    
19. cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    
20. '---------------------------------------  SQL查询语句   ------------------- ------------------- -------------------
    
21. SQL = "SELECT * FROM [Sheet1$] where 本月出勤天数（B列）>= 20 And 本月出勤工时（C列） >= 180 ORDER BY 本月业绩（D列） DESC"
    
22. Set rs = cnn.Execute(SQL) '将SQL语句获得的数据传递给数据集
    
23. '---------------------------------------   SQL结果处理  ------------------- ------------------- -------------------
    
24. arr1 = rs.getrows '将表数据传给数组
    
25. For i = 0 To UBound(arr1)
    
26.      n = n + 1
    
27.     dic(arr1(0, i)) = n '字典记录排名
    
28. Next i
    
29. 
    
30. For i = 2 To UBound(brr)  '查字典获取排名
    
31.   If Not dic.exists(arr(i, 1)) Then
    
32.   brr(i, 1) = ""
    
33.   Else
    
34.   brr(i, 1) = dic(arr(i, 1))
    
35.   End If
    
36. Next i
    
37. With Sheets("sheet1")
    
38.     .Range(.Cells(1, nCol), .Cells(nRow, nCol)).ClearContents
    
39.     .Range(.Cells(1, nCol), .Cells(nRow, nCol)) = brr
    
40. End With
    
41. 
    
42. rs.Close    '关闭数据集
    
43. cnn.Close     '关闭数据库连接
    
44. Set rs = Nothing
    
45. Set cnn = Nothing    '将CNN从内存中删除。
    
46. Set dic = Nothing
    
47. Application.ScreenUpdating = True
    
48. Application.DisplayAlerts = True
    
49. MsgBox Timer - t
    
50. End Sub
    
51. 
    

复制代码