请字典+数组的高手请进

cxh2010

zhaogang1960 发表于 2012-4-8 23:59
7楼数组法效果不错，由于成绩总表中班别是有序排列的，可以分别查找第一个和最后一个“四(1)”，这样就可以 ...

赵大哥，如果能做到A2选择后自动完成，那就更好了

zhaogang1960

cxh2010 发表于 2012-4-9 08:32
赵大哥，如果能做到A2选择后自动完成，那就更好了

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

复制代码

2012.4.8.rar (24.91 KB, 下载次数: 75)

2012-4-9 08:44 上传

点击文件名下载附件

cxh2010

zhaogang1960 发表于 2012-4-9 08:44

非常好，谢谢！再次麻烦：关于“班档”表A2自动设置数据有效性（根据”成绩总分“表的A2：A列最后单元格的不重复内容）

zhaogang1960

cxh2010 发表于 2012-4-9 09:00
非常好，谢谢！再次麻烦：关于“班档”表A2自动设置数据有效性（根据”成绩总分“表的A2：A列最后单元格的 ...

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Address(0, 0) <> "A2:B2" Then Exit Sub
   
3.     Dim arr, i&, d As Object
   
4.     With Sheets("成绩总表")
   
5.         arr = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
   
6.     End With
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     For i = 1 To UBound(arr)
   
9.         d(arr(i, 1)) = ""
   
10.     Next
    
11.     With Target.Validation
    
12.         .Delete
    
13.         .Add 3, 1, 1, Join(d.keys, ",")
    
14.     End With
    
15. End Sub
    

复制代码

2012.4.8.rar (25.28 KB, 下载次数: 92)

2012-4-9 09:14 上传

点击文件名下载附件

cxh2010

zhaogang1960 发表于 2012-4-9 09:14

非常了不起，{:soso_e179:}{:soso_e160:}{:soso_e163:}

dragonthree

zhaogang1960 发表于 2012-4-8 22:49
短信收到，没有使用字典+数组，因为数组排序麻烦，写到工作表上排序也挺麻烦
下面代码使用ADO筛选和排序， ...

学习赵版了！！

dragonthree

cxh2010 发表于 2012-4-9 08:31
大师，能做到A2选择后自动完成吗

用一CHANGE事件不就完了吗？

cxh2010

dragonthree 发表于 2012-4-9 10:13
用一CHANGE事件不就完了吗？

谢谢您的指导

风云际会6

发现没有人使用字典+数组，自己用字典+数组做了一个：
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address(0, 0) <> "A2" Then Exit Sub
Dim arr, brr(1 To 34, 1 To 15), crr(), aa, d, h, i, j, k, a()
s = Sheet1.Range("a65536").End(xlUp).Row
  arr = Sheet1.Range("a2:E" & s)
   ReDim crr(1 To UBound(arr), 1 To 5)
    ReDim a(1 To UBound(arr))
     r = 0
     For i = 1 To UBound(arr)
      If arr(i, 1) = Range("a2") Then
      m = m + 1
       crr(m, 1) = arr(i, 2): crr(m, 2) = arr(i, 3): crr(m, 3) = arr(i, 4): crr(m, 4) = arr(i, 5)
        crr(m, 5) = arr(i, 5) + arr(i, 3) + arr(i, 4)
         a(m) = arr(i, 5) + arr(i, 3) + arr(i, 4)
          End If
           Next
          Set d = CreateObject("Scripting.Dictionary")
           For i = m To 1 Step -1
           u = u + 1
            b = Application.Small(a, i)
             If Not d.exists(b) Then
              d(b) = u
              End If
               Next
               w = d.keys
                For j = 0 To UBound(w)
                 For h = 1 To m
                  If crr(h, 5) = w(j) Then
                    ss = ss + 1
                   If ss < 35 Then
                    brr(ss, 1) = d(crr(h, 5))
                     brr(ss, 2) = crr(h, 1): brr(ss, 3) = crr(h, 2): brr(ss, 4) = crr(h, 3): brr(ss, 5) = crr(h, 4): brr(ss, 6) = crr(h, 5)
                     Else
                      aa = aa + 1
                     brr(aa, 9) = d(crr(h, 5))
                     brr(aa, 10) = crr(h, 1): brr(aa, 11) = crr(h, 2): brr(aa, 12) = crr(h, 3): brr(aa, 13) = crr(h, 4): brr(aa, 14) = crr(h, 5)
                     End If
                     End If
                     Next
                     Next
                     
               Range("a35").Resize(34, 15) = brr
     
End Sub

cxh2010

风云际会6 发表于 2012-4-10 09:08
发现没有人使用字典+数组，自己用字典+数组做了一个：
Private Sub Worksheet_Change(ByVal Target As Ran ...

厉害 ，谢谢！不过A2选择后代码不执行，请测试。