大家都来把毕业题代码来秀一秀，互相观摩学习。

思密达0

考试已经结束了，我们都来把毕业题的代码来贴一贴，大家可以互相互相观摩学习一下，如果能加上必要的注释就更好了，同时也欢迎船长和两位学委也来贴一贴，有时间就指点一下。

我就先来个抛砖引玉：

1. Sub TONGJI()
   
2. Dim d1 As New Dictionary, d2 As New Dictionary, Arr1, Arr2, ARR3, i&, j&, X&, t As Double
   
3. 'T = Timer
   
4. With ThisWorkbook
   
5. 
   
6.     X = .Worksheets("统考成绩").Range("A65536").End(3).Row                                      '最后一行的行号
   
7.     If X < 3 Then MsgBox "统考成绩表中没有数据，请复制成绩到此表后再运行": Exit Sub
   
8.     Arr1 = .Worksheets("统考成绩").Range("B3:E" & .Worksheets("统考成绩").Range("A65536").End(3).Row)   '如果行号小于3就判断没有数据退出
   
9.    
   
10.     For i = 1 To UBound(Arr1)
    
11.         If Not d1.Exists(Arr1(i, 1)) And Len(Arr1(i, 1)) > 0 Then                               '如果字典中不存在就添加到D1和D2中
    
12.             d1(Arr1(i, 1)) = d1.Count + 1
    
13.             d2.Add (Arr1(i, 1)), New Dictionary                                                 '创建嵌套字典
    
14.         End If
    
15.         d2(Arr1(i, 1))(Arr1(i, 2)) = ""                                                         '把学生姓名加入到嵌套字典中
    
16.     Next i
    
17.    
    
18.     ReDim Arr2(1 To d1.Count, 1 To 9)                                                           '重新定义数组使其行数与D1相同
    
19.     For i = 1 To UBound(Arr1)
    
20.         Select Case Arr1(i, 3)
    
21.         Case Is = "语文"
    
22.             Arr2(d1(Arr1(i, 1)), 2) = Arr2(d1(Arr1(i, 1)), 2) + Arr1(i, 4)                      '把语文成绩按学校班级累计
    
23.             If Arr1(i, 4) >= 60 Then                                                            '如果成绩及格，累计到及格人数中，并在嵌套字典的项值中连接字符"1"
    
24.                 Arr2(d1(Arr1(i, 1)), 3) = Arr2(d1(Arr1(i, 1)), 3) + 1
    
25.                 d2(Arr1(i, 1))(Arr1(i, 2)) = d2(Arr1(i, 1))(Arr1(i, 2)) & 1
    
26.             End If
    
27.         Case Is = "数学"
    
28.             Arr2(d1(Arr1(i, 1)), 4) = Arr2(d1(Arr1(i, 1)), 4) + Arr1(i, 4)
    
29.             If Arr1(i, 4) >= 60 Then
    
30.                 Arr2(d1(Arr1(i, 1)), 5) = Arr2(d1(Arr1(i, 1)), 5) + 1
    
31.                 d2(Arr1(i, 1))(Arr1(i, 2)) = d2(Arr1(i, 1))(Arr1(i, 2)) & 2
    
32.             End If
    
33.         Case Is = "英语"
    
34.             Arr2(d1(Arr1(i, 1)), 7) = Arr2(d1(Arr1(i, 1)), 7) + Arr1(i, 4)
    
35.             If Arr1(i, 4) >= 60 Then
    
36.                 Arr2(d1(Arr1(i, 1)), 8) = Arr2(d1(Arr1(i, 1)), 8) + 1
    
37.                 d2(Arr1(i, 1))(Arr1(i, 2)) = d2(Arr1(i, 1))(Arr1(i, 2)) & 3
    
38.             End If
    
39.         End Select
    
40.     Next i
    
41.    
    
42.     For i = 1 To UBound(Arr2)
    
43.         Arr2(i, 1) = d2.Items(i - 1).Count                                                      '统计学校班级人数
    
44.         Arr2(i, 2) = WorksheetFunction.Round(Arr2(i, 2) / Arr2(i, 1), 1)                        '求平均分
    
45.         Arr2(i, 4) = WorksheetFunction.Round(Arr2(i, 4) / Arr2(i, 1), 1)
    
46.         Arr2(i, 6) = WorksheetFunction.Round(Arr2(i, 7) / Arr2(i, 1), 1)
    
47.         ARR3 = d2.Items(i - 1).Items                                                            '把子字典的项值赋值给数组
    
48.         For j = 0 To UBound(ARR3)
    
49.             If InStr(ARR3(j), "1") > 0 And InStr(ARR3(j), "2") > 0 And InStr(ARR3(j), "3") > 0 Then    '如果包含字符123，说明此人全部及格
    
50.                 Arr2(i, 9) = Arr2(i, 9) + 1                                                     '累计全部合格人数
    
51.             End If
    
52.         Next j
    
53.         Set ARR3 = Nothing
    
54.     Next i
    
55.     With .Worksheets("统计结果")
    
56.         .Range("A3:J65536").Clear
    
57.         .Range("A3").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d1.Keys)     '将字典的关键字赋值给单元格
    
58.         .Range("B3").Resize(UBound(Arr2), UBound(Arr2, 2)) = Arr2                               '将数组赋值给单元格
    
59.         X = .Range("A" & Rows.Count).End(3).Row
    
60.         .Range("C3:C" & X & ",E3:E" & X & ",G3:H" & X).NumberFormatLocal = "#0.0_ "
    
61.         With .Range("A3:J" & X).Borders
    
62.             .LineStyle = xlContinuous
    
63.             .Weight = xlThin
    
64.         End With
    
65.     End With
    
66. End With
    
67. 'T = Timer - T
    
68. 'MsgBox "运行时间" & T & "秒"
    
69. End Sub

复制代码

chenzhi_juan

1. ub 按钮1_Click()
   
2.   Application.ScreenUpdating = False
   
3.   Application.DisplayAlerts = False
   
4.   On Error Resume Next
   
5.     Dim t: t = Timer
   
6.      Dim d As New Dictionary, d1 As New Dictionary, d2 As New Dictionary
   
7.      Dim arr_总(), arr_明细, i, k, lastrow_总&, lastrow_明细&
   
8.       With Sheets("统考成绩")
   
9.          lastrow_明细 = .Range("b" & Cells.Rows.Count).End(xlUp).Row
   
10.          arr_明细 = .Range("a3:e" & lastrow_明细)  '将统考成绩装入数组提速
    
11.       End With
    
12.       
    
13.       For i = 1 To UBound(arr_明细)
    
14.          If d.Exists(arr_明细(i, 2)) = False Then
    
15.            k = k + 1
    
16.            d(arr_明细(i, 2)) = k    '确定学校班在汇总数组的位置
    
17.            ReDim Preserve arr_总(1 To 10, 1 To k)   '增加数组的行号，写出需要转置
    
18.             arr_总(1, k) = arr_明细(i, 2)  '将不重复的学校班写入数组的第一列
    
19.             Set d1(arr_明细(i, 2)) = New Dictionary  '设定不重复记录的子字典
    
20.               d1(arr_明细(i, 2))(arr_明细(i, 1)) = ""
    
21.               arr_总(2, k) = d1(arr_明细(i, 2)).Count
    
22.            Else
    
23.             d1(arr_明细(i, 2))(arr_明细(i, 1)) = ""
    
24.             arr_总(2, d(arr_明细(i, 2))) = d1(arr_明细(i, 2)).Count  '此句可以指定每个学校班的人数
    
25.       End If
    
26.       
    
27.          sr = arr_明细(i, 2) & arr_明细(i, 1) & arr_明细(i, 3)  '将前三项连接起来，求各科的平均成绩
    
28.          
    
29.         If arr_明细(i, 4) = "语文" Then
    
30.           arr_总(3, d(arr_明细(i, 2))) = arr_总(3, d(arr_明细(i, 2))) + arr_明细(i, 5)
    
31.              If arr_明细(i, 5) >= 60 Then
    
32.                arr_总(4, d(arr_明细(i, 2))) = 1 + arr_总(4, d(arr_明细(i, 2)))
    
33.                d2(sr) = d2(sr) + 1
    
34.              End If
    
35.            ElseIf arr_明细(i, 4) = "数学" Then
    
36.           arr_总(5, d(arr_明细(i, 2))) = arr_总(5, d(arr_明细(i, 2))) + arr_明细(i, 5)
    
37.              If arr_明细(i, 5) >= 60 Then
    
38.                arr_总(6, d(arr_明细(i, 2))) = 1 + arr_总(6, d(arr_明细(i, 2)))
    
39.                d2(sr) = d2(sr) + 1
    
40.              End If
    
41.             ElseIf arr_明细(i, 4) = "英语" Then
    
42.           arr_总(8, d(arr_明细(i, 2))) = arr_总(8, d(arr_明细(i, 2))) + arr_明细(i, 5)
    
43.              If arr_明细(i, 5) >= 60 Then
    
44.                arr_总(9, d(arr_明细(i, 2))) = 1 + arr_总(9, d(arr_明细(i, 2)))
    
45.                d2(sr) = d2(sr) + 1
    
46.              End If
    
47.           End If
    
48.         If d2(sr) = 3 Then '当各项成绩均及格时，科目数为3
    
49.            arr_总(10, d(arr_明细(i, 2))) = arr_总(10, d(arr_明细(i, 2))) + 1
    
50.         End If
    
51.     Next
    
52.    
    
53.     For i = 1 To k
    
54.       arr_总(3, i) = Round(arr_总(3, i) / arr_总(2, i), 1)  '将总数除以人数得到平均数
    
55.       arr_总(5, i) = Round(arr_总(5, i) / arr_总(2, i), 1)
    
56.       arr_总(7, i) = Round(arr_总(8, i) / arr_总(2, i), 1)
    
57.     Next
    
58.    
    
59.     With Sheets("统计结果") '在单元格中输出结果
    
60.       lastrow_总 = .Range("a" & Cells.Rows.Count).End(xlUp).Row
    
61.       If lastrow_总 > 2 Then .Range("a3:j" & lastrow_总).ClearContents
    
62.       .Range("a3").Resize(d.Count, 10) = Application.Transpose(arr_总)
    
63.     End With
    
64.    Debug.Print Timer - t & "秒"
    
65. 
    
66.   Application.ScreenUpdating = True
    
67.   Application.DisplayAlerts = True
    
68. End Sub

复制代码

tough2012

1. Sub 统计()
   
2. Range("a3:j" & [j65536].End(3).Row + 2).ClearContents
   
3. On Error Resume Next</P>
   
4. <P>Dim t As Double
   
5. t = Timer
   
6. Dim d As New Dictionary
   
7. Dim d1 As New Dictionary
   
8. Dim d2 As New Dictionary
   
9. Dim d3 As New Dictionary
   
10. Dim arr, arr1, arr2
    
11. Dim i%
    
12. arr = Sheet1.Range("a3:e" & Sheet1.Range("e65536").End(3).Row)
    
13.     For i = 1 To UBound(arr, 1) / 3
    
14.         d(arr(i, 2)) = d(arr(i, 2)) + 1
    
15.         If d1.Exists(arr(i, 2)) = False Then
    
16.             d1(arr(i, 2)) = d1.Count + 1
    
17.         End If
    
18.     Next i
    
19.     arr1 = [c1:g1]
    
20.     For i = 1 To 3
    
21.         d2(arr1(1, 2 * i - 1)) = 2 * i - 1
    
22.     Next i
    
23.     ReDim arr2(1 To d.Count, 1 To 8)
    
24.     For i = 1 To UBound(arr, 1)
    
25.         arr2(d1(arr(i, 2)), d2(arr(i, 4))) = arr2(d1(arr(i, 2)), d2(arr(i, 4))) + arr(i, 5)
    
26.         If arr(i, 5) >= 60 Then
    
27.             arr2(d1(arr(i, 2)), d2(arr(i, 4)) + 1 + d2(arr(i, 4)) \ 4) = arr2(d1(arr(i, 2)), d2(arr(i, 4)) + 1 + d2(arr(i, 4)) \ 4) + 1
    
28.         End If
    
29.         If arr(i, 2) <> arr(i + 1, 2) Then
    
30.             arr2(d1(arr(i, 2)), d2(arr(i, 4))) = Round(arr2(d1(arr(i, 2)), d2(arr(i, 4))) / d(arr(i, 2)), 1)
    
31.         End If
    
32.         If arr(i, 4) = "英语" Then
    
33.             arr2(d1(arr(i, 2)), 6) = arr2(d1(arr(i, 2)), 6) + arr(i, 5)
    
34.         End If
    
35.         If arr(i, 5) >= 60 And i <= UBound(arr, 1) / 3 Then
    
36.             d3(arr(i, 1) Mod UBound(arr, 1) / 3 & arr(i, 2)) = 1
    
37.         ElseIf i <= UBound(arr, 1) / 3 Then
    
38.            d3(arr(i, 1) Mod UBound(arr, 1) / 3 & arr(i, 2)) = 0
    
39.         ElseIf arr(i, 5) >= 60 Then
    
40.             d3(arr(i, 1) Mod UBound(arr, 1) / 3 & arr(i, 2)) = d3(arr(i, 1) Mod UBound(arr, 1) / 3 & arr(i, 2)) * 1
    
41.         Else
    
42.             d3(arr(i, 1) Mod UBound(arr, 1) / 3 & arr(i, 2)) = d3(arr(i, 1) Mod UBound(arr, 1) / 3 & arr(i, 2)) * 0
    
43.         End If
    
44.     Next i
    
45.     For i = 1 To d3.Count
    
46.         arr2(d1(arr(i, 2)), 8) = arr2(d1(arr(i, 2)), 8) + d3(arr(i, 1) Mod UBound(arr, 1) / 3 & arr(i, 2))
    
47.     Next i
    
48.     [a3].Resize(d.Count) = Application.Transpose(d.Keys)
    
49.     [b3].Resize(d.Count) = Application.Transpose(d.Items)
    
50.     [c3].Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
    
51.     MsgBox Timer - t
    
52. end sub

复制代码

sgyzzz

一楼代码中 大石4 的学生人数和平均分统计有误。你们来看看吧？

liuguansky

1. Option Explicit
   
2. Sub TTTTTTTTTTTT()
   
3.     Dim D As New Dictionary, Arr, Ar(1 To 60000, 1 To 10), i&, K&
   
4.     Dim Dxx As New Dictionary, KmC As Byte, XXr&, t, A&(1 To 60000)
   
5.     Const strKm$ = "  语文数学英语"
   
6.     t = Timer
   
7.     With Worksheets("统考成绩")
   
8.         Arr = .Range("a3:e" & .Cells(.Rows.Count, 1).End(3).Row).Value
   
9.     End With
   
10.     For i = 1 To UBound(Arr)
    
11.         If Not Dxx.Exists(Arr(i, 2)) Then
    
12.             D.Add Arr(i, 2), "": Set D(Arr(i, 2)) = New Dictionary
    
13.             K = K + 1: Dxx.Add Arr(i, 2), K: Ar(K, 1) = Arr(i, 2)
    
14.         End If
    
15.         KmC = InStr(1, strKm, Arr(i, 4)): XXr = Dxx(Arr(i, 2)): A(XXr) = A(XXr) + 1
    
16.         Ar(XXr, KmC) = Ar(XXr, KmC) + Arr(i, 5)
    
17.         If Not D(Arr(i, 2)).Exists(Arr(i, 3)) Then D(Arr(i, 2)).Add Arr(i, 3), 0
    
18.         If Arr(i, 5) >= 60 Then
    
19.             D(Arr(i, 2))(Arr(i, 3)) = D(Arr(i, 2))(Arr(i, 3)) + 1
    
20.             Ar(XXr, KmC + 1) = 1 + Ar(XXr, KmC + 1)
    
21.         End If
    
22.     Next i
    
23.     For i = 1 To K
    
24.         Ar(i, 2) = A(i) / 3
    
25.         Ar(i, 3) = VBA.Round(Ar(i, 3) / Ar(i, 2), 1)
    
26.         Ar(i, 5) = VBA.Round(Ar(i, 5) / Ar(i, 2), 1)
    
27.         Ar(i, 9) = Ar(i, 8): Ar(i, 8) = Ar(i, 7)
    
28.         Ar(i, 7) = VBA.Round(Ar(i, 7) / Ar(i, 2), 1)
    
29.         Arr = D(Ar(i, 1)).Items
    
30.         For XXr = 0 To UBound(Arr)
    
31.             If Arr(XXr) Mod 3 = 0 And Arr(XXr) > 0 Then
    
32.                 Ar(i, 10) = Ar(i, 10) + Arr(XXr) / 3
    
33.             End If
    
34.         Next XXr
    
35.     Next i
    
36.     With Worksheets("统计结果")
    
37.         .Range("a3:j" & Rows.Count).ClearContents
    
38.         .[a3].Resize(K, 10) = Ar
    
39.     End With
    
40.     Debug.Print "处理完毕，用时：" & Timer - t
    
41. End Sub

复制代码