要求总表生成分表问题

shenjianrong163

请参考附件：


00.rar (41.51 KB, 下载次数: 12)

2020-5-27 21:19 上传

点击文件名下载附件

779846526

shenjianrong163 发表于 2020-5-27 21:19
请参考附件：

太感谢了，再次谢谢老大，祝您生活愉快

779846526

shenjianrong163 发表于 2020-5-27 21:19
请参考附件：

老大您好，我昨晚测试了下，发现课表数据变化后，教师课表代码运行不了，麻烦您抽空帮我看下行吗 测试中的问题.zip (61.07 KB, 下载次数: 6)

2020-5-28 06:14 上传

点击文件名下载附件

shenjianrong163

779846526 发表于 2020-5-28 06:14
老大您好，我昨晚测试了下，发现课表数据变化后，教师课表代码运行不了，麻烦您抽空帮我看下行吗

只有课程没有教师这种情况怎样处理？

779846526

shenjianrong163 发表于 2020-5-28 10:27
只有课程没有教师这种情况怎样处理？

只有课程，没有老师，在班级表上要显示，没有教师的课程不要生成教师课表

shenjianrong163

779846526 发表于 2020-5-28 11:26
只有课程，没有老师，在班级表上要显示，没有教师的课程不要生成教师课表

1. Sub 教师课表()
   
2.     Dim i%, j%, k%, r%, t%, d, arr, brr()
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     r = 1
   
5.     With Sheets("全部班级课表")
   
6.         arr = .UsedRange
   
7.         For j = 1 To UBound(arr, 2)
   
8.             If arr(4, j) = "星期二" Then t = j - 2: Exit For
   
9.         Next
   
10.         For i = 6 To UBound(arr)
    
11.             For j = 2 To UBound(arr, 2) Step t
    
12.                 For k = 1 To t
    
13.                     If UBound(Split(arr(i, j + k - 1), Chr(10))) > 0 Then
    
14.                         If InStr(arr(i, j + k - 1), ":") > 0 Then '有冒号
    
15.                             If Len(Split(arr(i, j + k - 1), Chr(10))(0)) And Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then '回车符的前后两部分都有内容
    
16.                                 If Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1) = Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1) Then '一节课同时有两种情况，并且是同一人
    
17.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
18.                                     d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0) & "（" & Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0) & "）", Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
19.                                 Else  '一节课同时有两种情况，并且是两个人
    
20.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) = CreateObject("Scripting.Dictionary")
    
21.                                     d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
22.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
23.                                     d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
24.                                 End If
    
25.                             ElseIf Len(Split(arr(i, j + k - 1), Chr(10))(0)) Then '前半部分有内容
    
26.                                 If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) = CreateObject("Scripting.Dictionary")
    
27.                                 d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
28.                             ElseIf Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then  '后半部分有内容
    
29.                                 If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
30.                                 d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
31.                             End If
    
32.                         Else
    
33.                             If Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then
    
34.                                 If Not d.Exists(Split(arr(i, j + k - 1), Chr(10))(1)) Then Set d(Split(arr(i, j + k - 1), Chr(10))(1)) = CreateObject("Scripting.Dictionary")
    
35.                                 d(Split(arr(i, j + k - 1), Chr(10))(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(arr(i, j + k - 1), Chr(10))(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
36.                             End If
    
37.                         End If
    
38.                     End If
    
39.                 Next
    
40.             Next
    
41.         Next
    
42.     End With
    
43.     With Sheets("教师课表")
    
44.         .UsedRange.Clear
    
45.         .Rows("1:" & d.Count * (t + 3)).RowHeight = 30
    
46.         .Range("A1:G" & d.Count * (t + 3)).Font.Name = "宋体"
    
47.         .Range("A1:G" & d.Count * (t + 3)).Font.Size = 10
    
48.         .Range("A1:G" & d.Count * (t + 3)).HorizontalAlignment = xlCenter
    
49.         .Range("A1:G" & d.Count * (t + 3)).VerticalAlignment = xlCenter
    
50.         .Columns("A:B").ColumnWidth = 8.43
    
51.         .Columns("C:G").ColumnWidth = 21.86
    
52.         For Each kk In d.Keys
    
53.             If Len(Trim(kk)) Then
    
54.                 ReDim brr(1 To t + 2, 1 To 6)
    
55.                 brr(1, 1) = kk & "课表"
    
56.                 For j = 2 To 6
    
57.                     brr(2, j) = "星期" & Application.Text(j - 1, "[DBNum1]")
    
58.                 Next
    
59.                 For j = 3 To UBound(brr)
    
60.                     brr(j, 1) = arr(5, j - 1)
    
61.                 Next
    
62.                 For i = 2 To UBound(brr)
    
63.                     For j = 2 To 6
    
64.                         If d(kk).Exists(brr(2, j) & brr(i, 1)) Then brr(i, j) = d(kk)(brr(2, j) & brr(i, 1))(0) & Chr(10) & d(kk)(brr(2, j) & brr(i, 1))(2)
    
65.                     Next
    
66.                 Next
    
67.                 .Range("B" & r).Resize(1, 6).Merge
    
68.                 .Range("B" & r).Font.Size = 20
    
69.                 .Range("B" & r).Resize(UBound(brr), UBound(brr, 2)) = brr
    
70.                 .Range("B" & r + 1 & ":G" & r + UBound(brr) - 1).Borders.LineStyle = xlContinuous
    
71.                 r = .Cells(.Rows.Count, 2).End(xlUp).Row + 2
    
72.             End If
    
73.         Next
    
74.     End With
    
75. End Sub
    

复制代码

shenjianrong163

根据你的表格数据格式的变化重新调整了代码：

1. Sub 班级课表()
   
2.     Dim i%, j%, k%, r%, t%, arr, brr()
   
3.     r = 1
   
4.     With Sheets("全部班级课表")
   
5.         arr = .UsedRange
   
6.         For j = 1 To UBound(arr, 2)
   
7.             If arr(4, j) = "星期二" Then t = j - 2: Exit For
   
8.         Next
   
9.     End With
   
10.     With Sheets("班级课表")
    
11.         .UsedRange.Clear
    
12.         .Rows("1:" & UBound(arr) * (t + 3)).RowHeight = 30
    
13.         .Range("A1:G" & UBound(arr) * (t + 3)).Font.Name = "宋体"
    
14.         .Range("A1:G" & UBound(arr) * (t + 3)).Font.Size = 10
    
15.         .Range("A1:G" & UBound(arr) * (t + 3)).HorizontalAlignment = xlCenter
    
16.         .Range("A1:G" & UBound(arr) * (t + 3)).VerticalAlignment = xlCenter
    
17.         .Columns("A:B").ColumnWidth = 8.43
    
18.         .Columns("C:G").ColumnWidth = 21.86
    
19.         For i = 6 To UBound(arr)
    
20.             ReDim brr(1 To t + 2, 1 To 6)
    
21.             brr(1, 1) = arr(i, 1) & "课表"
    
22.             For j = 2 To 6
    
23.                 brr(2, j) = "星期" & Application.Text(j - 1, "[DBNum1]")
    
24.             Next
    
25.             For j = 3 To UBound(brr)
    
26.                 brr(j, 1) = arr(5, j - 1)
    
27.             Next
    
28.             For j = 2 To UBound(arr, 2) Step t
    
29.                 For k = 1 To t
    
30.                     brr(k + 2, Int(j / t) + 2) = arr(i, j + k - 1)
    
31.                 Next
    
32.             Next
    
33.             .Range("B" & r).Resize(1, 6).Merge
    
34.             .Range("B" & r).Font.Size = 20
    
35.             .Range("B" & r).Resize(UBound(brr), UBound(brr, 2)) = brr
    
36.             .Range("B" & r + 1 & ":G" & r + UBound(brr) - 1).Borders.LineStyle = xlContinuous
    
37.             r = .Cells(.Rows.Count, 2).End(xlUp).Row + 2
    
38.         Next
    
39.     End With
    
40. End Sub
    
41. 
    
42. 
    
43. Sub 教师课表()
    
44.     Dim i%, j%, k%, r%, t%, d, arr, brr()
    
45.     Set d = CreateObject("Scripting.Dictionary")
    
46.     r = 1
    
47.     With Sheets("全部班级课表")
    
48.         arr = .UsedRange
    
49.         For j = 1 To UBound(arr, 2)
    
50.             If arr(4, j) = "星期二" Then t = j - 2: Exit For
    
51.         Next
    
52.         For i = 6 To UBound(arr)
    
53.             For j = 2 To UBound(arr, 2) Step t
    
54.                 For k = 1 To t
    
55.                     If UBound(Split(arr(i, j + k - 1), Chr(10))) > 0 Then
    
56.                         If InStr(arr(i, j + k - 1), ":") > 0 Then '有冒号
    
57.                             If Len(Split(arr(i, j + k - 1), Chr(10))(0)) And Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then '回车符的前后两部分都有内容
    
58.                                 If Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1) = Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1) Then '一节课同时有两种情况，并且是同一人
    
59.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
60.                                     d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0) & "（" & Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0) & "）", Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
61.                                 Else  '一节课同时有两种情况，并且是两个人
    
62.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) = CreateObject("Scripting.Dictionary")
    
63.                                     d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
64.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
65.                                     d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
66.                                 End If
    
67.                             ElseIf Len(Split(arr(i, j + k - 1), Chr(10))(0)) Then '前半部分有内容
    
68.                                 If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) = CreateObject("Scripting.Dictionary")
    
69.                                 d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
70.                             ElseIf Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then  '后半部分有内容
    
71.                                 If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
72.                                 d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
73.                             End If
    
74.                         Else
    
75.                             If Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then
    
76.                                 If Not d.Exists(Split(arr(i, j + k - 1), Chr(10))(1)) Then Set d(Split(arr(i, j + k - 1), Chr(10))(1)) = CreateObject("Scripting.Dictionary")
    
77.                                 d(Split(arr(i, j + k - 1), Chr(10))(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(arr(i, j + k - 1), Chr(10))(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
78.                             End If
    
79.                         End If
    
80.                     End If
    
81.                 Next
    
82.             Next
    
83.         Next
    
84.     End With
    
85.     With Sheets("教师课表")
    
86.         .UsedRange.Clear
    
87.         .Rows("1:" & d.Count * (t + 3)).RowHeight = 30
    
88.         .Range("A1:G" & d.Count * (t + 3)).Font.Name = "宋体"
    
89.         .Range("A1:G" & d.Count * (t + 3)).Font.Size = 10
    
90.         .Range("A1:G" & d.Count * (t + 3)).HorizontalAlignment = xlCenter
    
91.         .Range("A1:G" & d.Count * (t + 3)).VerticalAlignment = xlCenter
    
92.         .Columns("A:B").ColumnWidth = 8.43
    
93.         .Columns("C:G").ColumnWidth = 21.86
    
94.         For Each kk In d.Keys
    
95.             If Len(Trim(kk)) Then
    
96.                 ReDim brr(1 To t + 2, 1 To 6)
    
97.                 brr(1, 1) = kk & "课表"
    
98.                 For j = 2 To 6
    
99.                     brr(2, j) = "星期" & Application.Text(j - 1, "[DBNum1]")
    
100.                 Next
     
101.                 For j = 3 To UBound(brr)
     
102.                     brr(j, 1) = arr(5, j - 1)
     
103.                 Next
     
104.                 For i = 2 To UBound(brr)
     
105.                     For j = 2 To 6
     
106.                         If d(kk).Exists(brr(2, j) & brr(i, 1)) Then brr(i, j) = d(kk)(brr(2, j) & brr(i, 1))(0) & Chr(10) & d(kk)(brr(2, j) & brr(i, 1))(2)
     
107.                     Next
     
108.                 Next
     
109.                 .Range("B" & r).Resize(1, 6).Merge
     
110.                 .Range("B" & r).Font.Size = 20
     
111.                 .Range("B" & r).Resize(UBound(brr), UBound(brr, 2)) = brr
     
112.                 .Range("B" & r + 1 & ":G" & r + UBound(brr) - 1).Borders.LineStyle = xlContinuous
     
113.                 r = .Cells(.Rows.Count, 2).End(xlUp).Row + 2
     
114.             End If
     
115.         Next
     
116.     End With
     
117. End Sub

复制代码

shenjianrong163

调整后的附件：


测试问题.rar (62.79 KB, 下载次数: 7)

2020-5-28 11:50 上传

点击文件名下载附件

779846526

shenjianrong163 发表于 2020-5-28 11:50
调整后的附件：

再次感谢老大的帮忙，测试发现有部分老师的课表结果不对，比如于红军老师的星期五下午财会981班的西方会计（单周课）没有填写，正确填写的格式是单周的写上面，双周的写下面

shenjianrong163

779846526 发表于 2020-5-28 12:14
再次感谢老大的帮忙，测试发现有部分老师的课表结果不对，比如于红军老师的星期五下午财会981班的西方会 ...

条件判断很多，看代码眼花缭乱，你先测试一下：

1. Sub 教师课表()
   
2.     Dim i%, j%, k%, r%, t%, d, arr, brr()
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     r = 1
   
5.     With Sheets("全部班级课表")
   
6.         arr = .UsedRange
   
7.         For j = 1 To UBound(arr, 2)
   
8.             If arr(4, j) = "星期二" Then t = j - 2: Exit For
   
9.         Next
   
10.         For i = 6 To UBound(arr)
    
11.             For j = 2 To UBound(arr, 2) Step t
    
12.                 For k = 1 To t
    
13.                     If UBound(Split(arr(i, j + k - 1), Chr(10))) > 0 Then
    
14.                         If InStr(arr(i, j + k - 1), ":") > 0 Then '有冒号
    
15.                             If Len(Split(arr(i, j + k - 1), Chr(10))(0)) And Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then '回车符的前后两部分都有内容
    
16.                                 If Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1) = Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1) Then '一节课同时有两种情况，并且是同一人
    
17.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
18.                                     d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0) & "|" & Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
19.                                 Else  '一节课同时有两种情况，并且是两个人
    
20.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) = CreateObject("Scripting.Dictionary")
    
21.                                     If Not d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)).Exists(arr(4, j) & arr(5, j + k - 1)) Then
    
22.                                         d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1)) '单周
    
23.                                     Else
    
24.                                         d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1))(0) & Chr(10) & d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1))(2), Split(arr(i, j + k - 1), Chr(10))(1), Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0) & Chr(10) & arr(i, 1)) '单双周
    
25.                                     End If
    
26.                                     If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
27.                                     If Not d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)).Exists(arr(4, j) & arr(5, j + k - 1)) Then
    
28.                                         d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1)) '双周
    
29.                                     Else
    
30.                                         d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1))(0) & Chr(10) & d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1))(2), Split(arr(i, j + k - 1), Chr(10))(1), Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0) & Chr(10) & arr(i, 1)) '单双周
    
31.                                     End If
    
32.                                 End If
    
33.                             ElseIf Len(Split(arr(i, j + k - 1), Chr(10))(0)) Then '前半部分有内容
    
34.                                 If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1)) = CreateObject("Scripting.Dictionary")
    
35.                                 d(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(0), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
36.                             ElseIf Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then  '后半部分有内容
    
37.                                 If Not d.Exists(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) Then Set d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1)) = CreateObject("Scripting.Dictionary")
    
38.                                 d(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(Split(arr(i, j + k - 1), Chr(10))(1), ":")(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
39.                             End If
    
40.                         Else
    
41.                             If Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then
    
42.                                 If Not d.Exists(Split(arr(i, j + k - 1), Chr(10))(1)) Then Set d(Split(arr(i, j + k - 1), Chr(10))(1)) = CreateObject("Scripting.Dictionary")
    
43.                                 d(Split(arr(i, j + k - 1), Chr(10))(1))(arr(4, j) & arr(5, j + k - 1)) = Array(Split(arr(i, j + k - 1), Chr(10))(0), Split(arr(i, j + k - 1), Chr(10))(1), arr(i, 1))
    
44.                             End If
    
45.                         End If
    
46.                     End If
    
47.                 Next
    
48.             Next
    
49.         Next
    
50.     End With
    
51.     With Sheets("教师课表")
    
52.         .UsedRange.Clear
    
53.         .Rows("1:" & d.Count * (t + 3)).RowHeight = 52.5
    
54.         .Range("A1:G" & d.Count * (t + 3)).Font.Name = "宋体"
    
55.         .Range("A1:G" & d.Count * (t + 3)).Font.Size = 10
    
56.         .Range("A1:G" & d.Count * (t + 3)).HorizontalAlignment = xlCenter
    
57.         .Range("A1:G" & d.Count * (t + 3)).VerticalAlignment = xlCenter
    
58.         .Columns("A:B").ColumnWidth = 8.43
    
59.         .Columns("C:G").ColumnWidth = 21.86
    
60.         For Each kk In d.Keys
    
61.             If Len(Trim(kk)) Then
    
62.                 ReDim brr(1 To t + 2, 1 To 6)
    
63.                 brr(1, 1) = kk & "课表"
    
64.                 For j = 2 To 6
    
65.                     brr(2, j) = "星期" & Application.Text(j - 1, "[DBNum1]")
    
66.                 Next
    
67.                 For j = 3 To UBound(brr)
    
68.                     brr(j, 1) = arr(5, j - 1)
    
69.                 Next
    
70.                 For i = 2 To UBound(brr)
    
71.                     For j = 2 To 6
    
72.                         If d(kk).Exists(brr(2, j) & brr(i, 1)) Then brr(i, j) = d(kk)(brr(2, j) & brr(i, 1))(0) & Chr(10) & d(kk)(brr(2, j) & brr(i, 1))(2)
    
73.                     Next
    
74.                 Next
    
75.                 .Range("B" & r).Resize(1, 6).Merge
    
76.                 .Range("B" & r).Font.Size = 20
    
77.                 .Range("B" & r).Resize(UBound(brr), UBound(brr, 2)) = brr
    
78.                 .Range("B" & r + 1 & ":G" & r + UBound(brr) - 1).Borders.LineStyle = xlContinuous
    
79.                 r = .Cells(.Rows.Count, 2).End(xlUp).Row + 2
    
80.             End If
    
81.         Next
    
82.     End With
    
83. End Sub
    

复制代码