用vba求各科级次(大量数据)

rzflj

各位大哥大姐，我这里有一组数据（学生成绩)，一共有14科目，3个年级，共6300人,我想用一段代码求各科级次，我自己用累加法写代码时间太长，请问有没有什么好办法？如要时间短，代码应该如何写？有附件

yjh_27

做个记号。
多长时间你能接受？

zax010

“各科级次”按班级，年级，还是按全部排序？

yjh_27

我的电脑8.1s

lanyuu

1. Sub test()
   
2.     Dim arr1, arr2, tm
   
3.     tm = Timer
   
4.     arr1 = Sheet1.Range("e2:r2101")
   
5.     Sheet1.Range("t2:ag2101") = 1
   
6.     arr2 = Sheet1.Range("t2:ag2101")
   
7.     For i = 1 To UBound(arr1) - 1
   
8.         For j = i + 1 To UBound(arr1)
   
9.             For k = 1 To 14
   
10.                 If arr1(i, k) > arr1(j, k) Then
    
11.                     arr2(j, k) = arr2(j, k) + 1
    
12.                 ElseIf arr1(i, k) < arr1(j, k) Then
    
13.                     arr2(i, k) = arr2(i, k) + 1
    
14.                 End If
    
15.             Next k
    
16.         Next j
    
17.     Next i
    
18.     Sheet1.Range("t2:ag2101") = arr2
    
19.    
    
20.    
    
21.     arr1 = Sheet1.Range("e2102:r4201")
    
22.     Sheet1.Range("t2102:ag4201") = 1
    
23.     arr2 = Sheet1.Range("t2102:ag4201")
    
24.     For i = 1 To UBound(arr1) - 1
    
25.         For j = i + 1 To UBound(arr1)
    
26.             For k = 1 To 14
    
27.                 If arr1(i, k) > arr1(j, k) Then
    
28.                     arr2(j, k) = arr2(j, k) + 1
    
29.                 ElseIf arr1(i, k) < arr1(j, k) Then
    
30.                     arr2(i, k) = arr2(i, k) + 1
    
31.                 End If
    
32.             Next k
    
33.         Next j
    
34.     Next i
    
35.     Sheet1.Range("t2102:ag4201") = arr2
    
36.    
    
37.     arr1 = Sheet1.Range("e4202:r6301")
    
38.     Sheet1.Range("t4202:ag6301") = 1
    
39.     arr2 = Sheet1.Range("t4202:ag6301")
    
40.     For i = 1 To UBound(arr1) - 1
    
41.         For j = i + 1 To UBound(arr1)
    
42.             For k = 1 To 14
    
43.                 If arr1(i, k) > arr1(j, k) Then
    
44.                     arr2(j, k) = arr2(j, k) + 1
    
45.                 ElseIf arr1(i, k) < arr1(j, k) Then
    
46.                     arr2(i, k) = arr2(i, k) + 1
    
47.                 End If
    
48.             Next k
    
49.         Next j
    
50.     Next i
    
51.     Sheet1.Range("t4202:ag6301") = arr2
    
52.     MsgBox Timer - tm
    
53.    
    
54. End Sub
    
55. 
    

复制代码

学习一下，累加花了43秒，

rzflj

yjh_27 发表于 2014-3-10 20:20
我的电脑8.1s

谢谢，在我的电脑上运行的时间是2.875秒。代码虽然还没看懂，但我会认真学习的。在此真心的感谢yjh_27

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Application.ScreenUpdating = False
   
4.   t = Timer
   
5.   With Worksheets("sheet1")
   
6.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.     arr = .Range("a1:ag" & r)
   
8.   End With
   
9.   With Worksheets("sheet2")
   
10.     .Select
    
11.     .Cells.Delete
    
12.     .Range("b1").Resize(r, 1) = Application.Index(arr, 0, 1)
    
13.     .Range("a1") = "序号"
    
14.     .Range("a2").Resize(r - 1, 1) = "=row()-1"
    
15.     .Range("a2").Resize(r - 1, 1).Value = .Range("a2").Resize(r - 1, 1).Value
    
16.     For j = 5 To 18
    
17.       .Cells(1, 3).Resize(r - 1, 1) = Application.Index(arr, 0, j)
    
18.       .Range("a1").Resize(r, 3).Sort key1:=Range("b2"), order1:=xlAscending, Key2:=Range("c2"), Order2:=xlDescending, Header:=xlYes
    
19.       .Cells(2, 4) = 1
    
20.       For i = 2 To r - 2
    
21.         If .Cells(i, 2) <> .Cells(i - 1, 2) Then
    
22.           .Cells(i, 4) = 1
    
23.         Else
    
24.           If .Cells(i, 3) = .Cells(i - 1, 3) Then
    
25.             .Cells(i, 4) = .Cells(i - 1, 4)
    
26.           Else
    
27.             .Cells(i, 4) = .Cells(i - 1, 4) + 1
    
28.           End If
    
29.         End If
    
30.       Next
    
31.       .Range("a1").Resize(r, 4).Sort key1:=Range("a2"), order1:=xlAscending, Header:=xlYes
    
32.       .Range("d2").Resize(r - 1, 4).Copy Worksheets("sheet1").Cells(2, j + 15)
    
33.     Next
    
34.   End With
    
35.   Application.ScreenUpdating = True
    
36.   Worksheets("sheet1").Select
    
37.   MsgBox Timer - t
    
38. End Sub
    

复制代码

chxw68

利用sheet2做辅助表，共用时7秒多。供参考。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Application.ScreenUpdating = False
   
4.   t = Timer
   
5.   With Worksheets("sheet1")
   
6.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
7.     arr = .Range("a1:ag" & r)
   
8.   End With
   
9.   With Worksheets("sheet2")
   
10.     .Select
    
11.     .Cells.Delete
    
12.     .Range("b1").Resize(r, 1) = Application.Index(arr, 0, 1)
    
13.     .Range("a1") = "序号"
    
14.     .Range("a2").Resize(r - 1, 1) = "=row()-1"
    
15.     .Range("a2").Resize(r - 1, 1).Value = .Range("a2").Resize(r - 1, 1).Value
    
16.     For j = 5 To 18
    
17.       .Cells(1, 3).Resize(r, 1) = Application.Index(arr, 0, j)
    
18.       .Range("a1").Resize(r, 3).Sort key1:=Range("b2"), order1:=xlAscending, Key2:=Range("c2"), Order2:=xlDescending, Header:=xlYes
    
19.       .Range("d1").Resize(r, 1).ClearContents
    
20.       brr = .Range("b1:d" & r)
    
21.       For i = 2 To r
    
22.         If Len(brr(i, 2)) <> 0 Then
    
23.           If brr(i, 1) <> brr(i - 1, 1) Then
    
24.             brr(i, 3) = 1
    
25.           Else
    
26.             If brr(i, 2) = brr(i - 1, 2) Then
    
27.               brr(i, 3) = brr(i - 1, 3)
    
28.             Else
    
29.               brr(i, 3) = brr(i - 1, 3) + 1
    
30.             End If
    
31.           End If
    
32.         End If
    
33.       Next
    
34.       .Range("d1").Resize(r, 1) = Application.Index(brr, 0, 3)
    
35.       .Range("a1").Resize(r, 4).Sort key1:=Range("a2"), order1:=xlAscending, Header:=xlYes
    
36.       .Range("d2").Resize(r - 1, 4).Copy Worksheets("sheet1").Cells(2, j + 15)
    
37.     Next
    
38.   End With
    
39.   Application.ScreenUpdating = True
    
40.   Worksheets("sheet1").Select
    
41.   MsgBox Timer - t
    
42. End Sub
    

复制代码

chxw68

又优化了一下，运行时间缩短到了1.39秒。