Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2791|回复: 7

[已解决]我想用VBA来提取班级课表及教师课表

[复制链接]
发表于 2016-3-21 22:37 | 显示全部楼层 |阅读模式
我想用vba来提取班级课表及教师课表,问题说明在批注中。
最佳答案
2016-3-22 11:18
代码已关联到微调按钮中。
  1. Sub 个人课程表()
  2.     arr = Sheet1.Range("a1:bh43")
  3.     Dim brr(1 To 8, 1 To 5)
  4.     With Sheet2
  5.         For n = 1 To 2
  6.             If n = 1 Then js = .[d2] Else js = .[d15] '老师
  7.             For i = 4 To UBound(arr)
  8.                 c = Int((i + 4.1) / 8)       '行数对应Brr列(星期)
  9.                 r = arr(i, 2)   '每天课数对应brr行
  10.                 For j = 4 To UBound(arr, 2) Step 2
  11.                     If arr(i, j) = js Then brr(r, c) = arr(i, j - 1)
  12.                 Next
  13.             Next
  14.             If n = 1 Then .[b5].Resize(8, 5) = brr Else .[b17].Resize(8, 5) = brr
  15.             Erase brr
  16.         Next
  17.     End With
  18.         
  19. End Sub

  20. Sub 班级课程表()
  21.     arr = Sheet1.Range("a1:bh43")
  22.     Dim brr(1 To 8, 1 To 5)
  23.     With Sheet3
  24.         For n = 1 To 2
  25.             If n = 1 Then xbj = .[d2] Else xbj = .[d14] '老师
  26.             Set xrng = Sheet1.Rows(3).Find(xbj, lookat:=xlWhole)
  27.             If xrng Is Nothing Then Exit Sub
  28.             j = xrng.Column
  29.             For i = 4 To UBound(arr)
  30.                 c = Int((i + 4.1) / 8)       '行数对应Brr列(星期)
  31.                 r = arr(i, 2)   '每天课数对应brr行
  32.                 brr(r, c) = arr(i, j)
  33.             Next
  34.             If n = 1 Then .[b4].Resize(8, 5) = brr Else .[b16].Resize(8, 5) = brr
  35.             Erase brr
  36.         Next
  37.     End With
  38. End Sub
复制代码

用VBA提取班级课表及教师课表.zip

176.75 KB, 下载次数: 34

发表于 2016-3-22 11:18 | 显示全部楼层    本楼为最佳答案   
代码已关联到微调按钮中。
  1. Sub 个人课程表()
  2.     arr = Sheet1.Range("a1:bh43")
  3.     Dim brr(1 To 8, 1 To 5)
  4.     With Sheet2
  5.         For n = 1 To 2
  6.             If n = 1 Then js = .[d2] Else js = .[d15] '老师
  7.             For i = 4 To UBound(arr)
  8.                 c = Int((i + 4.1) / 8)       '行数对应Brr列(星期)
  9.                 r = arr(i, 2)   '每天课数对应brr行
  10.                 For j = 4 To UBound(arr, 2) Step 2
  11.                     If arr(i, j) = js Then brr(r, c) = arr(i, j - 1)
  12.                 Next
  13.             Next
  14.             If n = 1 Then .[b5].Resize(8, 5) = brr Else .[b17].Resize(8, 5) = brr
  15.             Erase brr
  16.         Next
  17.     End With
  18.         
  19. End Sub

  20. Sub 班级课程表()
  21.     arr = Sheet1.Range("a1:bh43")
  22.     Dim brr(1 To 8, 1 To 5)
  23.     With Sheet3
  24.         For n = 1 To 2
  25.             If n = 1 Then xbj = .[d2] Else xbj = .[d14] '老师
  26.             Set xrng = Sheet1.Rows(3).Find(xbj, lookat:=xlWhole)
  27.             If xrng Is Nothing Then Exit Sub
  28.             j = xrng.Column
  29.             For i = 4 To UBound(arr)
  30.                 c = Int((i + 4.1) / 8)       '行数对应Brr列(星期)
  31.                 r = arr(i, 2)   '每天课数对应brr行
  32.                 brr(r, c) = arr(i, j)
  33.             Next
  34.             If n = 1 Then .[b4].Resize(8, 5) = brr Else .[b16].Resize(8, 5) = brr
  35.             Erase brr
  36.         Next
  37.     End With
  38. End Sub
复制代码

用VBA提取班级课表及教师课表.rar

150.6 KB, 下载次数: 24

回复

使用道具 举报

 楼主| 发表于 2016-3-22 14:52 | 显示全部楼层
grf1973 发表于 2016-3-22 11:18
代码已关联到微调按钮中。

若在教师课表中,单元格中的内容形式为:班级+科目,如何实现呢?
回复

使用道具 举报

发表于 2016-3-22 15:03 | 显示全部楼层
上楼第33句 brr(r, c) = arr(i, j) 改为 brr(r, c) = xbj & "/" & arr(i, j)
回复

使用道具 举报

 楼主| 发表于 2016-3-22 15:18 | 显示全部楼层
本帖最后由 yangfx163 于 2016-3-22 15:37 编辑
grf1973 发表于 2016-3-22 15:03
上楼第33句 brr(r, c) = arr(i, j) 改为 brr(r, c) = xbj & "/" & arr(i, j)

我说的是不是班级课程表,而是说教师任课表。我的意思是若在班级课表课程单元格中:教师名+课程;若在教师个人任课表中,则:班级名+课程。
回复

使用道具 举报

发表于 2016-3-22 15:48 | 显示全部楼层
  1. Sub 个人课程表()
  2.     arr = Sheet1.Range("a1:bh43")
  3.     Dim brr(1 To 8, 1 To 5)
  4.     With Sheet2
  5.         For n = 1 To 2
  6.             If n = 1 Then js = .[d2] Else js = .[d15] '老师
  7.             For i = 4 To UBound(arr)
  8.                 c = Int((i + 4.1) / 8)       '行数对应Brr列(星期)
  9.                 r = arr(i, 2)   '每天课数对应brr行
  10.                 For j = 4 To UBound(arr, 2) Step 2
  11.                     If arr(i, j) = js Then brr(r, c) = arr(3, j - 1) & "/" & arr(i, j - 1)
  12.                 Next
  13.             Next
  14.             If n = 1 Then .[b5].Resize(8, 5) = brr Else .[b17].Resize(8, 5) = brr
  15.             Erase brr
  16.         Next
  17.     End With
  18.         
  19. End Sub

  20. Sub 班级课程表()
  21.     arr = Sheet1.Range("a1:bh43")
  22.     Dim brr(1 To 8, 1 To 5)
  23.     With Sheet3
  24.         For n = 1 To 2
  25.             If n = 1 Then xbj = .[d2] Else xbj = .[d14] '老师
  26.             Set xrng = Sheet1.Rows(3).Find(xbj, lookat:=xlWhole)
  27.             If xrng Is Nothing Then Exit Sub
  28.             j = xrng.Column
  29.             For i = 4 To UBound(arr)
  30.                 c = Int((i + 4.1) / 8)       '行数对应Brr列(星期)
  31.                 r = arr(i, 2)   '每天课数对应brr行
  32.                 If arr(i, j + 1) = "" Then brr(r, c) = arr(i, j) Else brr(r, c) = arr(i, j + 1) & "/" & arr(i, j)
  33.             Next
  34.             If n = 1 Then .[b4].Resize(8, 5) = brr Else .[b16].Resize(8, 5) = brr
  35.             Erase brr
  36.         Next
  37.     End With
  38. End Sub
复制代码

用VBA提取班级课表及教师课表.rar

152.29 KB, 下载次数: 16

评分

参与人数 1 +6 收起 理由
today0427 + 6 当然棒辣!哈哈哈

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-3-22 15:57 | 显示全部楼层
本帖最后由 yangfx163 于 2016-3-22 16:00 编辑
grf1973 发表于 2016-3-22 15:48

老师真是太棒了,再过十年也追不上老师的十分之一,[em17][em17][em17]。老师已达随心所欲、无所不能的地步,望尘莫及这个词是不是从这儿来的[em07]。
回复

使用道具 举报

 楼主| 发表于 2016-3-23 08:32 | 显示全部楼层
在使用过程中,有一点问题,我再发一个救助帖。有个老师同时在两个班上课,只显示一个班课程,另一个无法显示。
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 05:59 , Processed in 0.407811 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表