请字典+数组的高手请进

zxc00 · 发表于 2014-1-13 21:42

zhaogang1960 发表于 2013-2-17 22:44
请看附件

版主，请教：如果班别里出现有两种情况如：一（1）和一年级，。。。能不能使代码在这两种混合的情况下都能正常呢

zhaogang1960 · 发表于 2014-1-13 22:05

zxc00 发表于 2014-1-13 21:42
版主，请教：如果班别里出现有两种情况如：一（1）和一年级，。。。能不能使代码在这两种混合的情况下都能 ...

我不知道
一年级和二(1)的对应关系，请说明

zxc00 · 发表于 2014-1-13 22:12

zhaogang1960 发表于 2014-1-13 22:05
我不知道
一年级和二(1)的对应关系，请说明

就是说一年级有一个班的时候，有的学校写成一年级，有的学校写成一(1)

zxc00 · 发表于 2014-1-13 22:18

zhaogang1960 发表于 2014-1-13 22:05
我不知道
一年级和二(1)的对应关系，请说明

版主，请看光明学校的一年级和其他学校的不一样，

zhaogang1960 · 发表于 2014-1-13 22:29

zxc00 发表于 2014-1-13 22:12
就是说一年级有一个班的时候，有的学校写成一年级，有的学校写成一(1)

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "B3" And Target.Address(0, 0) <> "G1" Then Exit Sub
If dicValidation Is Nothing Then Call Macro1
If Target.Address(0, 0) = "G1" Then
With [b3].Validation
.Delete
If dicValidation.Exists(Target.Value) Then .Add 3, 1, 1, Join(dicValidation(Target.Value).keys, ",")
End With
[b3] = ""
Exit Sub
End If
Range("A5:O38").ClearContents
If [b3] = "" Then Exit Sub
Dim c As Range, c2 As Range, arr, i&, 校$, 班$, brr(100, 1 To 2), n&, rng As Range
Dim crr(1 To 34, 1 To 15), hj As Double, j&, m&, mc&
校 = Range("g1").Value
班 = Range("b3").Value
With Sheets("学生成绩源")
Set c = .[a:a].Find(校, , , xlWhole)
If c Is Nothing Then
MsgBox 校 & "没有查到"
Exit Sub
End If
Set rng = c.Offset(, 2).Resize(.[a:a].Find(校, , , xlWhole, , xlPrevious).Row - c.Row + 1)
Set c2 = rng.Find(班, rng.Cells(rng.Rows.Count), , xlWhole)
If c2 Is Nothing Then
班 = Left$(班, 1) & "年级"
Set c2 = rng.Find(班, rng.Cells(rng.Rows.Count), , xlWhole)
If c2 Is Nothing Then
MsgBox Range("b3").Value & "没有查到"
Exit Sub
' Else
'
End If
End If
arr = c2.Resize(rng.Find(班, , , xlWhole, , xlPrevious).Row - c2.Row + 1, 5)
End With
n = 1
brr(1, 2) = 0
For i = 1 To UBound(arr)
If InStr(arr(i, 1), "年级") Then arr(i, 1) = Left$(arr(i, 1), 1) & "(1)"
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
Range("a5:o38") = crr
i = dicTeacher([g1] & 班)
[d3] = "任课老师 " & arrTeacher(1, 3) & "：" & arrTeacher(i, 3) & " " & arrTeacher(1, 4) & "：" & arrTeacher(i, 4) & " " & arrTeacher(1, 5) & "：" & arrTeacher(i, 5)
End Sub

复制代码

zhaogang1960 · 发表于 2014-1-13 23:19

zxc00 发表于 2014-1-13 22:56
谢谢，现在还有一个问题：如果老师任课工作表里的班别和成绩表里的不一样的时候，那能不能做到也能正常运 ...

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)
If InStr(arrTeacher(i, 2), "年级") Then arrTeacher(i, 2) = Left$(arrTeacher(i, 2), 1) & "(1)"
dicTeacher(arrTeacher(i, 1) & arrTeacher(i, 2)) = i
Next
End Sub

复制代码

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) <> "B3" And Target.Address(0, 0) <> "G1" Then Exit Sub
If dicValidation Is Nothing Then Call Macro1
If Target.Address(0, 0) = "G1" Then
With [b3].Validation
.Delete
If dicValidation.Exists(Target.Value) Then .Add 3, 1, 1, Join(dicValidation(Target.Value).keys, ",")
End With
[b3] = ""
Exit Sub
End If
Range("A5:O38").ClearContents
If [b3] = "" Then Exit Sub
Dim c As Range, c2 As Range, arr, i&, 校$, 班$, brr(100, 1 To 2), n&, rng As Range
Dim crr(1 To 34, 1 To 15), hj As Double, j&, m&, mc&
校 = Range("g1").Value
班 = Range("b3").Value
With Sheets("学生成绩源")
Set c = .[a:a].Find(校, , , xlWhole)
If c Is Nothing Then
MsgBox 校 & "没有查到"
Exit Sub
End If
Set rng = c.Offset(, 2).Resize(.[a:a].Find(校, , , xlWhole, , xlPrevious).Row - c.Row + 1)
Set c2 = rng.Find(班, rng.Cells(rng.Rows.Count), , xlWhole)
If c2 Is Nothing Then
班 = Left$(班, 1) & "年级"
Set c2 = rng.Find(班, rng.Cells(rng.Rows.Count), , xlWhole)
If c2 Is Nothing Then
MsgBox Range("b3").Value & "没有查到"
Exit Sub
End If
End If
arr = c2.Resize(rng.Find(班, , , xlWhole, , xlPrevious).Row - c2.Row + 1, 5)
End With
n = 1
brr(1, 2) = 0
For i = 1 To UBound(arr)
If InStr(arr(i, 1), "年级") Then arr(i, 1) = Left$(arr(i, 1), 1) & "(1)"
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
Range("a5:o38") = crr
s = [b3]
If InStr(s, "年级") Then s = Left$(s, 1) & "(1)"
i = dicTeacher([g1] & s)
[d3] = "任课老师 " & arrTeacher(1, 3) & "：" & arrTeacher(i, 3) & " " & arrTeacher(1, 4) & "：" & arrTeacher(i, 4) & " " & arrTeacher(1, 5) & "：" & arrTeacher(i, 5)
End Sub

复制代码

zhaogang1960 · 发表于 2014-1-13 22:33

请看附件

查询6 1.rar (43.95 KB, 下载次数: 14)

zxc00 · 发表于 2014-1-13 22:56

zhaogang1960 发表于 2014-1-13 22:33
请看附件

谢谢，现在还有一个问题：如果老师任课工作表里的班别和成绩表里的不一样的时候，那能不能做到也能正常运行？
如：光明学校的一年级：成绩表里显示是一年级，而老师任课表里又是一（1）
二年级：成绩表里显示是二（1），而老师任课表里又是二年级

zhaogang1960 · 发表于 2014-1-13 23:22

请测试附件

查询6 2.rar (43.73 KB, 下载次数: 33)

zxc00 · 发表于 2014-1-13 23:27

本帖最后由 zxc00 于 2014-1-13 23:31 编辑

zhaogang1960 发表于 2014-1-13 23:19

大侠很了不起，谢谢，辛苦了{:soso_e160:}

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

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

评分