请字典+数组的高手请进

cxh2010 · 发表于 2012-4-9 08:32

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

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

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

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

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

复制代码

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

cxh2010 · 发表于 2012-4-9 09:00

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

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

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

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

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

复制代码

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

cxh2010 · 发表于 2012-4-9 09:21

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

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

dragonthree · 发表于 2012-4-9 10:09

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

学习赵版了！！

dragonthree · 发表于 2012-4-9 10:13

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

用一CHANGE事件不就完了吗？

cxh2010 · 发表于 2012-4-9 14:40

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

谢谢您的指导

风云际会6 · 发表于 2012-4-10 09:08

发现没有人使用字典+数组，自己用字典+数组做了一个：
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 · 发表于 2012-4-10 17:05

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

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

		自动登录	找回密码
密码			免费注册

[求助] 请字典+数组的高手请进