请字典+数组的高手请进

tplk

非常感激您

zhaogang1960

tplk 发表于 2013-2-14 16:03
搞定了，谢谢老师的帮忙，真心感谢

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Target.Address(0, 0) <> "B3" And Target.Address(0, 0) <> "G1" Then Exit Sub
   
3.     If dicValidation Is Nothing Then Call Macro1
   
4.     If Target.Address(0, 0) = "G1" Then
   
5.         With [b3].Validation
   
6.             .Delete
   
7.             If dicValidation.Exists(Target.Value) Then .Add 3, 1, 1, Join(dicValidation(Target.Value).keys, ",")
   
8.         End With
   
9.         [b3] = ""
   
10.         Exit Sub
    
11.     End If
    
12.     Range("A5:O38").ClearContents
    
13.     If [b3] = "" Then Exit Sub
    
14.     Dim c As Range, c2 As Range, arr, i&, 校$, 班$, brr(100, 1 To 2), n&, rng As Range
    
15.     Dim crr(1 To 34, 1 To 15), hj As Double, j&, m&, mc&
    
16.     校 = Range("g1").Value
    
17.     班 = Range("b3").Value
    
18.     With Sheets("学生成绩源")
    
19.         Set c = .[a:a].Find(校, , , xlWhole)
    
20.         If c Is Nothing Then
    
21.             MsgBox 校 & "没有查到"
    
22.             Exit Sub
    
23.         End If
    
24.         Set rng = c.Offset(, 2).Resize(.[a:a].Find(校, , , xlWhole, , xlPrevious).Row - c.Row + 1)
    
25.         Set c2 = rng.Find(班, rng.Cells(rng.Rows.Count), , xlWhole)
    
26.         If c2 Is Nothing Then
    
27.             MsgBox 班 & "没有查到"
    
28.             Exit Sub
    
29.         End If
    
30.         arr = c2.Resize(rng.Find(班, , , xlWhole, , xlPrevious).Row - c2.Row + 1, 5)
    
31.     End With
    
32.     n = 1
    
33.     brr(1, 2) = 0
    
34.     For i = 1 To UBound(arr)
    
35.         hj = arr(i, 3) + arr(i, 4) + arr(i, 5)
    
36.         For j = 1 To n
    
37.             If hj >= brr(j, 2) Then
    
38.                 For m = n To j Step -1
    
39.                     brr(m + 1, 1) = brr(m, 1)
    
40.                     brr(m + 1, 2) = brr(m, 2)
    
41.                 Next
    
42.                 brr(j, 1) = i
    
43.                 brr(j, 2) = hj
    
44.                 Exit For
    
45.             End If
    
46.         Next
    
47.         n = n + 1
    
48.     Next
    
49.     For i = 1 To n - 1
    
50.         If i > 34 Then
    
51.             x = i - 34
    
52.             y = 8
    
53.         Else
    
54.             x = i
    
55.             y = 0
    
56.         End If
    
57.         If brr(i, 2) <> brr(i - 1, 2) Then mc = i
    
58.         crr(x, 1 + y) = mc
    
59.         For j = 2 To 5
    
60.             crr(x, j + y) = arr(brr(i, 1), j)
    
61.         Next
    
62.         crr(x, 6 + y) = brr(i, 2)
    
63.     Next
    
64.     Range("a5:o38") = crr
    
65. End Sub
    
66. 
    

复制代码

tplk

zhaogang1960 发表于 2013-2-14 14:32
请看附件

搞定了，谢谢老师的帮忙，真心感谢

zhaogang1960

tplk 发表于 2013-2-17 22:29
是下载52楼的附件直接运行的，是不是我安装Excel的兼容包影响呢？

本身就是2003工作簿，不用兼容包，再加一段代码试试看：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Address(0, 0) <> "G1" Then Exit Sub
    If dicValidation Is Nothing Then
        Call Macro1
    Else
        With Target.Validation
            .Delete
            .Add 3, 1, 1, Join(dicValidation.keys, ",")
        End With
    End If
End Sub

zhaogang1960

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

2013-2-17 22:44 上传

点击文件名下载附件

tplk

zhaogang1960 发表于 2013-2-17 22:20
请上传出错附件分析一下

是下载52楼的附件直接运行的，是不是我安装Excel的兼容包影响呢？

zhaogang1960

tplk 发表于 2013-2-17 22:13
是下载您上面的附件运行有时行有时不行。就是停在.Add 3, 1, 1, Join(dicValidation.keys, ",")'是这里出 ...

请上传出错附件分析一下

zhaogang1960

tplk 发表于 2013-2-17 21:58
老师，下载您写好的附件，代码运行有一个小问题有时正常，有时不行）：运行不行而停在这句代码.Add 3, 1, ...

是这段代码出错了？按理不应该，先请核对代码是否一致，如果一致，请上传出错附件
Sub Macro1()
    Dim arr, i&, s$
    Set dicValidation = CreateObject("scripting.dictionary")
    Set dicTeacher = CreateObject("scripting.dictionary")
    With Sheets("学生成绩源")
        arr = .Range("A2:C" & .Range("A65536").End(xlUp).Row)
    End With
    For i = 1 To UBound(arr)
        If Not dicValidation.Exists(arr(i, 1)) Then Set dicValidation(arr(i, 1)) = CreateObject("scripting.dictionary")
        dicValidation(arr(i, 1))(arr(i, 3)) = ""
    Next
    With [g1].Validation
        .Delete
        .Add 3, 1, 1, Join(dicValidation.keys, ",")'是这里出问题了？
    End With
    arrTeacher = Sheets("老师课表").[a1].CurrentRegion
    For i = 2 To UBound(arrTeacher)
        dicTeacher(arrTeacher(i, 1) & arrTeacher(i, 2)) = i
    Next
End Sub

tplk

zhaogang1960 发表于 2013-2-17 22:05
是这段代码出错了？按理不应该，先请核对代码是否一致，如果一致，请上传出错附件
Sub Macro1()
    Di ...

是下载您上面的附件运行有时行有时不行。就是停在.Add 3, 1, 1, Join(dicValidation.keys, ",")'是这里出问题了

tplk

zhaogang1960 发表于 2013-2-14 22:43
请看附件

老师，下载您写好的附件，代码运行有一个小问题有时正常，有时不行）：运行不行而停在这句代码.Add 3, 1, 1, Join(dicValidation.keys, ",")
不知道是什么原因