请字典+数组的高手请进

风云际会6

cxh2010 发表于 2012-4-17 22:17
大哥，当某班的某位学生的所有科目的成绩都为空时，代码运行出现了问题，请抽空看看，谢谢

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "A2" Then Exit Sub
    Range("A4:O37").ClearContents
    If Target = "" Then Exit Sub
    Dim c As Range, arr, i&, ban$, brr(100, 1 To 2), n&
    Dim crr(1 To 34, 1 To 15), hj As Double, j&, m&, mc&
    ban = Sheets("班档").Range("a2").Value
    With Sheets("成绩总表")
        Set c = .[a:a].Find(ban, , , xlWhole)
        If c Is Nothing Then
            MsgBox "没有查到"
            Exit Sub
        End If
        arr = c.Resize(.[a:a].Find(ban, , , xlWhole, , xlPrevious).Row - c.Row + 1, 5)
    End With
    n = 1
    brr(1, 2) = 0
    For i = 1 To UBound(arr)
        hj = arr(i, 3) + arr(i, 4) + arr(i, 5)
        For j = 1 To n
            If hj >= brr(j, 2) Then
                For m = n To j Step -1
                    brr(m + 1, 1) = brr(m, 1)
                    brr(m + 1, 2) = brr(m, 2)
                Next
                brr(j, 1) = i
                brr(j, 2) = hj
                Exit For
            End If
        Next
        n = n + 1
    Next
    For i = 1 To n - 1
        If i > 34 Then
            x = i - 34
            y = 8
        Else
            x = i
            y = 0
        End If
        If brr(i, 2) <> brr(i - 1, 2) Then mc = i
        crr(x, 1 + y) = mc
        For j = 2 To 5
            crr(x, j + y) = arr(brr(i, 1), j)
        Next
        crr(x, 6 + y) = brr(i, 2)
    Next
    Sheets("班档").Range("a4:o37") = crr
End Sub

tplk

zhaogang1960 发表于 2012-4-17 23:31

老师，新年好，这是一个双条件查询的求助，请进

zhaogang1960

tplk 发表于 2013-2-14 11:07
老师，新年好，这是一个双条件查询的求助，请进

太久了，已经全忘了，先请测试：

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

复制代码

zhaogang1960

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

2013-2-14 13:38 上传

点击文件名下载附件

tplk

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

老师，还有点小问题：
      当G1选“光明”，B3出现的有效性正确，又点击G1选“老朋”，B3出现的有效性不对阿（多了六（2））。
      如果连续点击G1选“老朋”，B3出现的有效性正确，又点击G1选“光明”，B3出现的有效性不对阿（少了一个六（2）。

请老师说说这个问题是什么原因的

tplk

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

老师，我下载了这个二级数据有效性，第二级的下拉列表更新快，但我不会借鉴，您看看，好吗

zhaogang1960

tplk 发表于 2013-2-14 13:59
老师，还有点小问题：
      当G1选“光明”，B3出现的有效性正确，又点击G1选“老朋”，B3出现的有效 ...

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

复制代码

zhaogang1960

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

2013-2-14 14:21 上传

点击文件名下载附件

zhaogang1960

tplk 发表于 2013-2-14 14:15
老师，我下载了这个二级数据有效性，第二级的下拉列表更新快，但我不会借鉴，您看看，好吗

这个好像也是我写的，不过是激活工作表时一次计算的，所以速度快些

zhaogang1960

tplk 发表于 2013-2-14 14:15
老师，我下载了这个二级数据有效性，第二级的下拉列表更新快，但我不会借鉴，您看看，好吗

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

复制代码