《新人求助》点击生成个人课表的同时，自动统计个人任课情况，填到模板的表格里，...

15117380152 · 发表于 2019-8-23 12:16

本帖最后由 15117380152 于 2019-8-23 22:40 编辑

《新人求助》根据总课表，点击生成个人课表的同时，自动统计个人任课情况，填到模板的表格里，根据模板单独另外生成教师个人课表，用VBA怎么实现，麻烦大师们帮我写段代码，谢谢，感激不尽！请见附件！在线等待中。。。。。。。附件已重新做修改说明！请各位老师就当练练手！帮个忙！谢谢！
QQ截图20190823113537.jpg

chxw68 · 发表于 2019-8-23 20:48

笔误，修改好了。

15117380152 · 发表于 2019-8-23 14:00

各位老师，请帮个忙呗！！！！！

donghui2363 · 发表于 2019-8-23 15:11

是想点一下按钮然后把总表里的所有老师都单独做一个像模板的那种表吗？

15117380152 · 发表于 2019-8-23 15:44

donghui2363 发表于 2019-8-23 15:11
是想点一下按钮然后把总表里的所有老师都单独做一个像模板的那种表吗？

是的，附件已重新做修改说明，谢谢！

donghui2363 · 发表于 2019-8-23 15:58

你的总课表，周一至周五不是横着排列的，还有就是在内容里也有合并单元格，很麻烦

15117380152 · 发表于 2019-8-23 16:56

donghui2363 发表于 2019-8-23 15:58
你的总课表，周一至周五不是横着排列的，还有就是在内容里也有合并单元格，很麻烦

星期横着排的太长了，如果有时间请帮忙看一下，，，，谢谢，辛苦了。

15117380152 · 发表于 2019-8-23 17:12

donghui2363 发表于 2019-8-23 15:58
你的总课表，周一至周五不是横着排列的，还有就是在内容里也有合并单元格，很麻烦

总课表内有些单元格看起来像合并的，但是不是，是因为两边单元里没输入内容，所以才被“占用”的！

chxw68 · 发表于 2019-8-23 17:51

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
vs = [{"早辅",1;"第一节",2;"第二节",3;"第三节",5;"第四节",6;"第五节",8;"第六节",9;"第七节",10;"第八节",12;"第九节",13}]
For i = 1 To UBound(vs)
d1(vs(i, 1)) = vs(i, 2)
Next
With Worksheets("总课表")
r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
c = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
arr = .Range("a1").Resize(r, c)
End With
For k = 3 To 33 Step 30
For j = 3 To UBound(arr, 2)
If Len(arr(k, j)) <> 0 Then
xq = arr(k, j)
n = InStr("一二三四五", Right(xq, 1)) * 2 - 1
End If
For i = k + 2 To k + 26 Step 2
If d1.exists(arr(i, 1)) Then
m = d1(arr(i, 1))
If Len(arr(i + 1, j)) <> 0 Then
If Not d.exists(arr(i + 1, j)) Then
ReDim brr(1 To 13, 1 To 10)
Else
brr = d(arr(i + 1, j))
End If
brr(m, n) = arr(k + 1, j)
brr(m, n + 1) = arr(i, j)
d(arr(i + 1, j)) = brr
End If
End If
Next
Next
Next
With Worksheets("模板")
.Range("a12:f16").ClearContents
For Each aa In d.keys
brr = d(aa)
d1.RemoveAll
For i = 1 To UBound(brr)
For j = 1 To UBound(brr, 2) Step 2
If Len(brr(i, j)) <> 0 Then
xm = brr(i, j) & "+" & brr(i, j + 1)
If Not d1.exists(xm) Then
ReDim crr(1 To 3)
crr(1) = brr(i, j)
crr(2) = brr(i, j + 1)
Else
crr = d1(xm)
End If
crr(3) = crr(3) + 1
d1(xm) = crr
End If
Next
Next
.Range("a4") = aa
m = 12
n = 1
For Each bb In d1.keys
crr = d1(bb)
.Cells(m, n) = crr(1)
.Cells(m, n + 1) = crr(2)
.Cells(m, n + 2) = crr(3)
m = m + 1
If m > 16 Then
m = 12
n = n + 3
End If
Next
.Range("i7").Resize(UBound(brr), UBound(brr, 2)) = brr
On Error Resume Next
Set ws = Worksheets(aa)
If Err = 0 Then
ws.Delete
End If
On Error GoTo 0
.Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet
.Name = aa
End With
Next
End With
End Sub

复制代码

chxw68 · 发表于 2019-8-23 17:51

详见附件。

chxw68 · 发表于 2019-8-23 18:12

又完善了一下。

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

[已解决] 《新人求助》点击生成个人课表的同时，自动统计个人任课情况，填到模板的表格里，...

评分