请字典+数组的高手请进

cxh2010

要求见附件，谢谢

longming3

进来学习一下，思路是字典求和，数组排序，得出结果

cxh2010

longming3 发表于 2012-4-8 22:15
进来学习一下，思路是字典求和，数组排序，得出结果

能否帮忙写写代码共享一下吗

zhaogang1960

短信收到，没有使用字典+数组，因为数组排序麻烦，写到工作表上排序也挺麻烦
下面代码使用ADO筛选和排序，用数组求名次，请测试：

1. Sub Macro1()
   
2.     Dim cnn As Object
   
3.     Dim SQL$, arr, brr(1 To 34, 5), i&, j&, m&, n&
   
4.     Application.ScreenUpdating = False
   
5.     Set cnn = CreateObject("ADODB.Connection")
   
6.     cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0;imex=1';data source=" & ThisWorkbook.FullName
   
7.     SQL = "select 姓名,语文,数学,英语,iif(isnull(语文),0,语文)+iif(isnull(数学),0,数学)+iif(isnull(英语),0,英语) as 总分 from [成绩总表$] where 班别='" & [a2] & "' order by iif(isnull(语文),0,语文)+iif(isnull(数学),0,数学)+iif(isnull(英语),0,英语) desc"
   
8.     arr = cnn.Execute(SQL).GetRows
   
9.     cnn.Close
   
10.     Set cnn = Nothing
    
11.     mx = UBound(arr, 2)
    
12.     Range("A4:O37").ClearContents
    
13.     On Error Resume Next
    
14.     For l = 0 To mx Step 34
    
15.         m = 0
    
16.         For i = l To l + 33
    
17.             If i > mx Then Exit For
    
18.             m = m + 1
    
19.             brr(m, 0) = i + 1
    
20.             If i > 0 Then
    
21.                 If arr(4, i) = arr(4, i - 1) Then
    
22.                     If m > 1 Then
    
23.                         brr(m, 0) = brr(m - 1, 0)
    
24.                     Else
    
25.                         brr(m, 0) = brr(34, 0)
    
26.                     End If
    
27.                 End If
    
28.             End If
    
29.             For j = 0 To 4
    
30.                 brr(m, j + 1) = arr(j, i)
    
31.             Next
    
32.         Next
    
33.         Cells(4, n + 1).Resize(m, 6) = brr
    
34.         n = n + 8
    
35.     Next
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    

复制代码

zhaogang1960

请看附件
2012.4.8.rar (30.9 KB, 下载次数: 113)

2012-4-8 22:52 上传

点击文件名下载附件

PurpleIdea

偶然看到，学到不少。3Q~~~

mimicai

纯数组做的，没用字典和ado：

1. Sub cs()
   
2.     Dim arr, i&, ban$, brr(100, 1 To 2), n&
   
3.     Dim crr(1 To 34, 1 To 15), hj As Double, j&, m&, mc&
   
4.     With Sheets("成绩总表")
   
5.         arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(3).Row).Value
   
6.     End With
   
7.     ban = Sheets("班档").Range("a2").Value
   
8.     n = 1
   
9.     brr(1, 2) = 0
   
10.     For i = 1 To UBound(arr)
    
11.         If arr(i, 1) = ban Then
    
12.             hj = arr(i, 3) + arr(i, 4) + arr(i, 5)
    
13.             For j = 1 To n
    
14.                 If hj > brr(j, 2) Then
    
15.                     For m = n To j Step -1
    
16.                         brr(m + 1, 1) = brr(m, 1)
    
17.                         brr(m + 1, 2) = brr(m, 2)
    
18.                     Next
    
19.                     brr(j, 1) = i
    
20.                     brr(j, 2) = hj
    
21.                     Exit For
    
22.                 End If
    
23.             Next
    
24.             n = n + 1
    
25.         End If
    
26.     Next
    
27.     For i = 1 To n - 1
    
28.         If i > 34 Then
    
29.             x = i - 34
    
30.             y = 8
    
31.         Else
    
32.             x = i
    
33.             y = 0
    
34.         End If
    
35.         If brr(i, 2) <> brr(i - 1, 2) Then mc = i
    
36.         crr(x, 1 + y) = mc
    
37.         For j = 2 To 5
    
38.             crr(x, j + y) = arr(brr(i, 1), j)
    
39.         Next
    
40.         crr(x, 6 + y) = brr(i, 2)
    
41.     Next
    
42.     Sheets("班档").Range("a4:o37") = crr
    
43. End Sub

复制代码

2012.4.8.rar (21.73 KB, 下载次数: 65)

2012-4-8 23:33 上传

点击文件名下载附件

zhaogang1960

7楼数组法效果不错，由于成绩总表中班别是有序排列的，可以分别查找第一个和最后一个“四(1)”，这样就可以不用判断了：

1. Sub cs()
   
2.     Dim c As Range, arr, i&, ban$, brr(100, 1 To 2), n&
   
3.     Dim crr(1 To 34, 1 To 15), hj As Double, j&, m&, mc&
   
4.     ban = Sheets("班档").Range("a2").Value
   
5.     With Sheets("成绩总表")
   
6.         Set c = .[a:a].Find(ban, , , xlWhole)
   
7.         If c Is Nothing Then
   
8.             MsgBox "没有查到"
   
9.             Exit Sub
   
10.         End If
    
11.         arr = c.Resize(.[a:a].Find(ban, , , xlWhole, , xlPrevious).Row - c.Row + 1, 5)
    
12.     End With
    
13. '    With Sheets("成绩总表")
    
14. '        arr = .Range("a2:e" & .Cells(Rows.Count, 1).End(3).Row).Value
    
15. '    End With
    
16.     n = 1
    
17.     brr(1, 2) = 0
    
18.     For i = 1 To UBound(arr)
    
19. '        If arr(i, 1) = ban Then
    
20.             hj = arr(i, 3) + arr(i, 4) + arr(i, 5)
    
21.             For j = 1 To n
    
22.                 If hj > brr(j, 2) Then
    
23.                     For m = n To j Step -1
    
24.                         brr(m + 1, 1) = brr(m, 1)
    
25.                         brr(m + 1, 2) = brr(m, 2)
    
26.                     Next
    
27.                     brr(j, 1) = i
    
28.                     brr(j, 2) = hj
    
29.                     Exit For
    
30.                 End If
    
31.             Next
    
32.             n = n + 1
    
33. '        End If
    
34.     Next
    
35.     For i = 1 To n - 1
    
36.         If i > 34 Then
    
37.             x = i - 34
    
38.             y = 8
    
39.         Else
    
40.             x = i
    
41.             y = 0
    
42.         End If
    
43.         If brr(i, 2) <> brr(i - 1, 2) Then mc = i
    
44.         crr(x, 1 + y) = mc
    
45.         For j = 2 To 5
    
46.             crr(x, j + y) = arr(brr(i, 1), j)
    
47.         Next
    
48.         crr(x, 6 + y) = brr(i, 2)
    
49.     Next
    
50.     Sheets("班档").Range("a4:o37") = crr
    
51. End Sub
    

复制代码

liucqa

排序用冒泡还是很慢的，一般处理这种排序问题，可以直接调用希尔排序或者快速排序。
把总分、人名和三科分数用","分隔成一个字符串，构成一个1维数组，然后就可以直接送入现成的希尔排序算法（灰袍的就行）里面进行处理（排序用val取总分），把排序出来的结果再进行填表就行了。这样几万人的排序也能在几秒钟之内解决。

cxh2010

mimicai 发表于 2012-4-8 23:33
纯数组做的，没用字典和ado：

大师，能做到A2选择后自动完成吗