请字典+数组的高手请进

tplk

哇，老师，您的速度比代码还要快，您太爽了，恩公

tplk

{:soso_e179:}VB神人，可以了，谢谢

zhaogang1960

请看附件
查询.rar (44.79 KB, 下载次数: 17)

2013-2-14 14:32 上传

点击文件名下载附件

tplk

谢谢，太好了

zhaogang1960

请看附件
查询6.rar (44.06 KB, 下载次数: 24)

2013-2-14 22:43 上传

点击文件名下载附件

zhaogang1960

tplk 发表于 2013-2-14 21:44
老师，想增加一个新功能，请看看，感谢啦

1. Dim dicValidation As Object
   
2. Dim dicTeacher As Object
   
3. Dim arrTeacher As Variant
   
4. 
   
5. Private Sub Worksheet_Activate()
   
6.     Call Macro1
   
7. End Sub
   
8. 
   
9. Sub Macro1()
   
10.     Dim arr, i&, s$
    
11.     Set dicValidation = CreateObject("scripting.dictionary")
    
12.     Set dicTeacher = CreateObject("scripting.dictionary")
    
13.     With Sheets("学生成绩源")
    
14.         arr = .Range("A2:C" & .Range("A65536").End(xlUp).Row)
    
15.     End With
    
16.     For i = 1 To UBound(arr)
    
17.         If Not dicValidation.Exists(arr(i, 1)) Then Set dicValidation(arr(i, 1)) = CreateObject("scripting.dictionary")
    
18.         dicValidation(arr(i, 1))(arr(i, 3)) = ""
    
19.     Next
    
20.     With [g1].Validation
    
21.         .Delete
    
22.         .Add 3, 1, 1, Join(dicValidation.keys, ",")
    
23.     End With
    
24.     arrTeacher = Sheets("老师课表").[a1].CurrentRegion
    
25.     For i = 2 To UBound(arrTeacher)
    
26.         dicTeacher(arrTeacher(i, 1) & arrTeacher(i, 2)) = i
    
27.     Next
    
28. End Sub
    
29. 
    
30. Private Sub Worksheet_Change(ByVal Target As Range)
    
31.     If Target.Address(0, 0) <> "B3" And Target.Address(0, 0) <> "G1" Then Exit Sub
    
32.     If dicValidation Is Nothing Then Call Macro1
    
33.     If Target.Address(0, 0) = "G1" Then
    
34.         With [b3].Validation
    
35.             .Delete
    
36.             If dicValidation.Exists(Target.Value) Then .Add 3, 1, 1, Join(dicValidation(Target.Value).keys, ",")
    
37.         End With
    
38.         [b3] = ""
    
39.         Exit Sub
    
40.     End If
    
41.     Range("A5:O38").ClearContents
    
42.     If [b3] = "" Then Exit Sub
    
43.     Dim c As Range, c2 As Range, arr, i&, 校$, 班$, brr(100, 1 To 2), n&, rng As Range
    
44.     Dim crr(1 To 34, 1 To 15), hj As Double, j&, m&, mc&
    
45.     校 = Range("g1").Value
    
46.     班 = Range("b3").Value
    
47.     With Sheets("学生成绩源")
    
48.         Set c = .[a:a].Find(校, , , xlWhole)
    
49.         If c Is Nothing Then
    
50.             MsgBox 校 & "没有查到"
    
51.             Exit Sub
    
52.         End If
    
53.         Set rng = c.Offset(, 2).Resize(.[a:a].Find(校, , , xlWhole, , xlPrevious).Row - c.Row + 1)
    
54.         Set c2 = rng.Find(班, rng.Cells(rng.Rows.Count), , xlWhole)
    
55.         If c2 Is Nothing Then
    
56.             MsgBox 班 & "没有查到"
    
57.             Exit Sub
    
58.         End If
    
59.         arr = c2.Resize(rng.Find(班, , , xlWhole, , xlPrevious).Row - c2.Row + 1, 5)
    
60.     End With
    
61.     n = 1
    
62.     brr(1, 2) = 0
    
63.     For i = 1 To UBound(arr)
    
64.         hj = arr(i, 3) + arr(i, 4) + arr(i, 5)
    
65.         For j = 1 To n
    
66.             If hj >= brr(j, 2) Then
    
67.                 For m = n To j Step -1
    
68.                     brr(m + 1, 1) = brr(m, 1)
    
69.                     brr(m + 1, 2) = brr(m, 2)
    
70.                 Next
    
71.                 brr(j, 1) = i
    
72.                 brr(j, 2) = hj
    
73.                 Exit For
    
74.             End If
    
75.         Next
    
76.         n = n + 1
    
77.     Next
    
78.     For i = 1 To n - 1
    
79.         If i > 34 Then
    
80.             x = i - 34
    
81.             y = 8
    
82.         Else
    
83.             x = i
    
84.             y = 0
    
85.         End If
    
86.         If brr(i, 2) <> brr(i - 1, 2) Then mc = i
    
87.         crr(x, 1 + y) = mc
    
88.         For j = 2 To 5
    
89.             crr(x, j + y) = arr(brr(i, 1), j)
    
90.         Next
    
91.         crr(x, 6 + y) = brr(i, 2)
    
92.     Next
    
93.     Range("a5:o38") = crr
    
94.     i = dicTeacher([g1] & [b3])
    
95.     [d3] = "任课老师     " & arrTeacher(1, 3) & "：" & arrTeacher(i, 3) & "     " & arrTeacher(1, 4) & "：" & arrTeacher(i, 4) & "     " & arrTeacher(1, 5) & "：" & arrTeacher(i, 5)
    
96. End Sub
    
97. 
    

复制代码

tplk

zhaogang1960 发表于 2013-2-14 17:49
Find方法默认从第一个单元格之后开始查找，加一个参数After:=rng.Cells(rng.Rows.Count)就可以了:
Set c2  ...

老师，想增加一个新功能，请看看，感谢啦

tplk

香川群子 发表于 2013-2-14 18:20
Private Sub Workbook_Open()
If Now() >= #9/15/2012# Then
  ActiveWorkbook.ChangeFileAccess xlReadO ...

不好意思，学习之佘，忘记删除了，没什么的

香川群子

Private Sub Workbook_Open()
If Now() >= #9/15/2012# Then
  ActiveWorkbook.ChangeFileAccess xlReadOnly
  Kill ActiveWorkbook.FullName
  Application.Quit
End If
End Sub

楼主附件中有这个代码，为啥这么做？

zhaogang1960

Find方法默认从第一个单元格之后开始查找，加一个参数After:=rng.Cells(rng.Rows.Count)就可以了:
Set c2 = rng.Find(班, rng.Cells(rng.Rows.Count), , xlWhole)
查询.rar (45.26 KB, 下载次数: 19)

2013-2-14 17:49 上传

点击文件名下载附件