请优化下程序

左小光

请优化下vba代码

左小光

请优化下vba代码，我把代码传来了

baofa2

1. Sub test0()
   
2.   
   
3.   Dim results(), data
   
4.   Dim i As Long, j As Long, k As Long
   
5.   Dim cnt As Long, pos As Long, colSize As Long
   
6.   
   
7.   With Worksheets(1).Range("A1").CurrentRegion
   
8.     data = Range(.Cells(1), .Offset(1)).Value
   
9.   End With
   
10.   ReDim results(1 To UBound(data), 1 To 100)
    
11.   
    
12.   pos = 1
    
13.   For j = 1 To 2
    
14.     results(pos, j) = data(pos, j)
    
15.   Next
    
16.   For colSize = j To 5
    
17.     results(pos, colSize) = Split("总分 级名次 班名次")(colSize - 3)
    
18.   Next
    
19.   
    
20.   For i = pos + 1 To UBound(data) - 1
    
21.     For j = 1 To 2
    
22.       results(i, j) = data(i, j)
    
23.     Next
    
24.     For j = 3 To UBound(data, 2)
    
25.       results(i, 3) = results(i, 3) + Val(data(i, j))
    
26.     Next
    
27.   Next
    
28.   For j = 3 To UBound(data, 2)
    
29.     results(pos, colSize) = data(pos, j)
    
30.     results(pos, colSize + 1) = data(pos, j) & "名次"
    
31.     For i = pos + 1 To UBound(data) - 1
    
32.       results(i, colSize) = data(i, j)
    
33.     Next
    
34.     colSize = colSize + 2
    
35.   Next
    
36.   colSize = colSize - 1
    
37.   
    
38.   For j = 6 To colSize Step 2
    
39.     cnt = 1
    
40.     QuickSort results, pos + 1, UBound(results) - 1, 1, colSize, j, True
    
41.     results(pos + 1, j + 1) = cnt
    
42.     For i = pos + 2 To UBound(results) - 1
    
43.       cnt = cnt + 1
    
44.       If results(i, j) < results(i - 1, j) Then results(i, j + 1) = cnt Else results(i, j + 1) = results(i - 1, j + 1)
    
45.     Next
    
46.   Next
    
47.   
    
48.   j = 3
    
49.   cnt = 1
    
50.   QuickSort results, pos + 1, UBound(results) - 1, 1, colSize, 3, True
    
51.   results(pos + 1, j + 1) = cnt
    
52.   For i = pos + 2 To UBound(results) - 1
    
53.     cnt = cnt + 1
    
54.     If results(i, j) < results(i - 1, j) Then results(i, j + 1) = cnt Else results(i, j + 1) = results(i - 1, j + 1)
    
55.   Next
    
56.   
    
57.   QuickSort results, pos + 1, UBound(results) - 1, 1, colSize, 1, False
    
58.   For i = 2 To UBound(results) - 1
    
59.     If results(i, 1) <> results(i + 1, 1) Then
    
60.       cnt = 1
    
61.       QuickSort results, pos + 1, i, 1, colSize, j, True
    
62.       results(pos + 1, j + 2) = cnt
    
63.       For k = pos + 2 To i
    
64.         cnt = cnt + 1
    
65.         If results(k, j) < results(k - 1, j) Then results(k, j + 2) = cnt Else results(k, j + 2) = results(k - 1, j + 2)
    
66.       Next
    
67.       pos = i
    
68.     End If
    
69.   Next
    
70.   
    
71.   With Worksheets(2).Range("A1")
    
72.     .CurrentRegion.Clear
    
73.     With .Resize(UBound(results) - 1, colSize)
    
74.       .Borders.LineStyle = xlContinuous
    
75.       .HorizontalAlignment = xlCenter
    
76.       .Value = results
    
77.     End With
    
78.   End With
    
79.   
    
80.   Beep
    
81. End Sub
    
82. 
    
83. Function QuickSort(ar, u As Long, d As Long, l As Long, r As Long, pos As Long, Optional IsDesc As Boolean = True)
    
84.   Dim t As Long, b As Long, j As Long, x As Long, pivot, swap
    
85.   t = u
    
86.   b = d
    
87.   pivot = ar((u + d) \ 2, pos)
    
88.   While t <= b
    
89.     If IsDesc Then
    
90.       Do
    
91.         If ar(t, pos) > pivot Then t = t + 1 Else Exit Do
    
92.       Loop While t < d
    
93.       Do
    
94.         If ar(b, pos) < pivot Then b = b - 1 Else Exit Do
    
95.       Loop While b > u
    
96.     Else
    
97.       Do
    
98.         If ar(t, pos) < pivot Then t = t + 1 Else Exit Do
    
99.       Loop While t < d
    
100.       Do
     
101.         If ar(b, pos) > pivot Then b = b - 1 Else Exit Do
     
102.       Loop While b > u
     
103.     End If
     
104.     If t < b Then
     
105.       For x = l To r
     
106.         swap = ar(t, x): ar(t, x) = ar(b, x): ar(b, x) = swap
     
107.       Next
     
108.       t = t + 1: b = b - 1
     
109.     Else
     
110.       If t = b Then t = t + 1: b = b - 1
     
111.     End If
     
112.   Wend
     
113.   If t < d Then QuickSort ar, t, d, l, r, pos, IsDesc
     
114.   If b > u Then QuickSort ar, u, b, l, r, pos, IsDesc
     
115. End Function

复制代码

左小光

非常感谢！我正在学习此代码与调式，速度非常快。

yynrzwh

级班科序示例.zip (155.46 KB, 下载次数: 15)

2024-5-2 11:01 上传

点击文件名下载附件

左小光

感谢各位大神的帮助，现成型我想要的了，分享给需要的朋友。

山海风云轩

左小光 发表于 2024-5-3 09:43
感谢各位大神的帮助，现成型我想要的了，分享给需要的朋友。

点赞         

baofa2

左小光 发表于 2024-5-3 09:43
感谢各位大神的帮助，现成型我想要的了，分享给需要的朋友。

……闲 练习……
见你好学且有所获练习新写一下仅供测试参考.zip (64.38 KB, 下载次数: 9)

2024-5-3 11:42 上传

点击文件名下载附件

titi012

参与一下，，，

1. Dim Brr()
   
2. 
   
3. Sub TTT()
   
4. 
   
5. Dim Arr, Nrr(), d As Object
   
6. Dim x&, y&, R&, N&, K
   
7. 
   
8. Set d = CreateObject("scripting.dictionary")
   
9. With Sheets("原始数据样式")
   
10.     R = .Cells(Rows.Count, 1).End(xlUp).Row
    
11.     Arr = .Range("a1:i" & R)
    
12. End With
    
13. ReDim Nrr(1 To R, 1 To 19)
    
14. ReDim Brr(1 To R - 1)
    
15. 
    
16. Rem 标题列
    
17. Nrr(1, 1) = Arr(1, 1)
    
18. Nrr(1, 2) = Arr(1, 2)
    
19. Nrr(1, 3) = "总分"
    
20. Nrr(1, 4) = "级名次"
    
21. Nrr(1, 5) = "班名次"
    
22. For y = 3 To 9
    
23.     Nrr(1, y * 2) = Arr(1, y)
    
24.     Nrr(1, y * 2 + 1) = Arr(1, y) & "名次"
    
25. Next y
    
26. Rem 数据
    
27. For x = 2 To R
    
28.     Nrr(x, 1) = Arr(x, 1)
    
29.     Nrr(x, 2) = Arr(x, 2)
    
30.     For y = 3 To 9
    
31.         Nrr(x, y * 2) = Arr(x, y)
    
32.         Nrr(x, 3) = Nrr(x, 3) + Arr(x, y)
    
33.     Next y
    
34.     d(Nrr(x, 1)) = 1 + d(Nrr(x, 1))
    
35.     Brr(x - 1) = Nrr(x, 3)
    
36. Next x
    
37. 
    
38. Rem 级排名
    
39. BrrPaiXu R - 1
    
40. For x = 2 To R
    
41.     Nrr(x, 4) = xRnk(Nrr(x, 3) + 0)
    
42. Next x
    
43. Rem 班排名
    
44. For Each K In d.keys
    
45.     ReDim Brr(1 To d(K))
    
46.     N = 0
    
47.     For x = 2 To R
    
48.         If Nrr(x, 1) Like K Then N = N + 1: Brr(N) = Nrr(x, 3)
    
49.     Next x
    
50.     BrrPaiXu N
    
51.     For x = 2 To R
    
52.         If Nrr(x, 1) Like K Then Nrr(x, 5) = xRnk(Nrr(x, 3) + 0)
    
53.     Next x
    
54. Next K
    
55. Rem 各科排名
    
56. For y = 6 To 18 Step 2
    
57.     ReDim Brr(1 To R - 1)
    
58.     N = 0
    
59.     For x = 2 To R
    
60.         Brr(x - 1) = Nrr(x, y)
    
61.     Next x
    
62.     BrrPaiXu R - 1
    
63.     For x = 2 To R
    
64.         Nrr(x, y + 1) = xRnk(Nrr(x, y) + 0)
    
65.     Next x
    
66. Next y
    
67. 
    
68. 
    
69. With Sheets("处理后的数据")
    
70.     .Cells.ClearContents
    
71.     .[a1].Resize(R, 19) = Nrr
    
72. End With
    
73. 
    
74. End Sub
    
75. 
    
76. Sub BrrPaiXu(M As Long)
    
77. 
    
78. Dim a&, b&, V As Double
    
79. For a = 1 To M - 1
    
80. For b = 1 To M - a
    
81.     If Brr(b) < Brr(b + 1) Then
    
82.         V = Brr(b)
    
83.         Brr(b) = Brr(b + 1)
    
84.         Brr(b + 1) = V
    
85.     End If
    
86. Next b
    
87. Next a
    
88. 
    
89. End Sub
    
90. 
    
91. Function xRnk(M As Double) As Long
    
92. 
    
93. Dim a&, b&, c&
    
94. a = LBound(Brr)
    
95. b = UBound(Brr)
    
96. Do
    
97.     c = (a + b) / 2
    
98.     If Brr(c) = M Then xRnk = c: Exit Do
    
99.     If Brr(c) < M Then b = c - 1 Else a = c + 1
    
100. Loop While a <= b
     
101. 
     
102. End Function

复制代码