要求总表生成分表问题

779846526

请路过的帮忙看成下这个 根据总表数据写出分表数据的问题如何 处理 00.zip (16.99 KB, 下载次数: 30)

2020-5-27 15:20 上传

点击文件名下载附件

3190496160

总课程表中，教师姓名和所上课程在一个单元格内，就给写代码带来很大难度，不是不可以完成，只是非常麻烦

779846526

3190496160 发表于 2020-5-27 16:43
总课程表中，教师姓名和所上课程在一个单元格内，就给写代码带来很大难度，不是不可以完成，只是非常麻烦

谢谢老大的回贴，总表中如果设置了自动换行的格式后，课程名是在第一行，老师名是第二行，不知这对写代码方便区分课程与老师吗

779846526

3190496160 发表于 2020-5-27 16:43
总课程表中，教师姓名和所上课程在一个单元格内，就给写代码带来很大难度，不是不可以完成，只是非常麻烦

请路过的帮忙看看吧

779846526

3190496160 发表于 2020-5-27 16:43
总课程表中，教师姓名和所上课程在一个单元格内，就给写代码带来很大难度，不是不可以完成，只是非常麻烦

谢谢您的回贴，关于课程名与老师名不好区分的问题可以这样处理，只要把总表中设置自动换行的格式，单元格中的第一行显示的是课程名，第二行显示的是老师名，第三行显示是场地名

3190496160

等明天有时间帮你看看吧，你这个问题非一时之功

shenjianrong163

先弄个班级课表：

1. Sub test() '班级课表
   
2.     Dim i%, j%, k%, r%, 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 + 2)).RowHeight = 30
    
13.         .Range("A1:G" & UBound(arr) * (t + 2)).Font.Name = "宋体"
    
14.         .Range("A1:G" & UBound(arr) * (t + 2)).Font.Size = 10
    
15.         .Range("A1:G" & UBound(arr) * (t + 2)).HorizontalAlignment = xlCenter
    
16.         .Range("A1:G" & UBound(arr) * (t + 2)).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

复制代码

779846526

shenjianrong163 发表于 2020-5-27 19:45
先弄个班级课表：

谢谢您的回贴，非常感谢

shenjianrong163

教师课表：

1. Sub test02() '教师课表
   
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 Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then
    
15.                             If InStr(arr(i, j + k - 1), ":") > 0 Then
    
16.                                 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")
    
17.                                 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))
    
18.                             Else
    
19.                                 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")
    
20.                                 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))
    
21.                             End If
    
22.                         End If
    
23.                     End If
    
24.                 Next
    
25.             Next
    
26.         Next
    
27.     End With
    
28.     With Sheets("教师课表")
    
29.         .UsedRange.Clear
    
30.         .Rows("1:" & d.Count * (t + 3)).RowHeight = 30
    
31.         .Range("A1:G" & d.Count * (t + 3)).Font.Name = "宋体"
    
32.         .Range("A1:G" & d.Count * (t + 3)).Font.Size = 10
    
33.         .Range("A1:G" & d.Count * (t + 3)).HorizontalAlignment = xlCenter
    
34.         .Range("A1:G" & d.Count * (t + 3)).VerticalAlignment = xlCenter
    
35.         .Columns("A:B").ColumnWidth = 8.43
    
36.         .Columns("C:G").ColumnWidth = 21.86
    
37.         For Each kk In d.Keys
    
38.             ReDim brr(1 To t + 2, 1 To 6)
    
39.             brr(1, 1) = kk & "课表"
    
40.             For j = 2 To 6
    
41.                 brr(2, j) = "星期" & Application.Text(j - 1, "[DBNum1]")
    
42.             Next
    
43.             For j = 3 To UBound(brr)
    
44.                 brr(j, 1) = arr(5, j - 1)
    
45.             Next
    
46.             For i = 2 To UBound(brr)
    
47.                 For j = 2 To 6
    
48.                     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)
    
49.                 Next
    
50.             Next
    
51.             .Range("B" & r).Resize(1, 6).Merge
    
52.             .Range("B" & r).Font.Size = 20
    
53.             .Range("B" & r).Resize(UBound(brr), UBound(brr, 2)) = brr
    
54.             .Range("B" & r + 1 & ":G" & r + UBound(brr) - 1).Borders.LineStyle = xlContinuous
    
55.             r = .Cells(.Rows.Count, 2).End(xlUp).Row + 2
    
56.         Next
    
57.     End With
    
58. 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 Len(Split(arr(i, j + k - 1), Chr(10))(1)) Then
    
57.                             If InStr(arr(i, j + k - 1), ":") > 0 Then
    
58.                                 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")
    
59.                                 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))
    
60.                             Else
    
61.                                 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")
    
62.                                 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))
    
63.                             End If
    
64.                         End If
    
65.                     End If
    
66.                 Next
    
67.             Next
    
68.         Next
    
69.     End With
    
70.     With Sheets("教师课表")
    
71.         .UsedRange.Clear
    
72.         .Rows("1:" & d.Count * (t + 3)).RowHeight = 30
    
73.         .Range("A1:G" & d.Count * (t + 3)).Font.Name = "宋体"
    
74.         .Range("A1:G" & d.Count * (t + 3)).Font.Size = 10
    
75.         .Range("A1:G" & d.Count * (t + 3)).HorizontalAlignment = xlCenter
    
76.         .Range("A1:G" & d.Count * (t + 3)).VerticalAlignment = xlCenter
    
77.         .Columns("A:B").ColumnWidth = 8.43
    
78.         .Columns("C:G").ColumnWidth = 21.86
    
79.         For Each kk In d.Keys
    
80.             ReDim brr(1 To t + 2, 1 To 6)
    
81.             brr(1, 1) = kk & "课表"
    
82.             For j = 2 To 6
    
83.                 brr(2, j) = "星期" & Application.Text(j - 1, "[DBNum1]")
    
84.             Next
    
85.             For j = 3 To UBound(brr)
    
86.                 brr(j, 1) = arr(5, j - 1)
    
87.             Next
    
88.             For i = 2 To UBound(brr)
    
89.                 For j = 2 To 6
    
90.                     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)
    
91.                 Next
    
92.             Next
    
93.             .Range("B" & r).Resize(1, 6).Merge
    
94.             .Range("B" & r).Font.Size = 20
    
95.             .Range("B" & r).Resize(UBound(brr), UBound(brr, 2)) = brr
    
96.             .Range("B" & r + 1 & ":G" & r + UBound(brr) - 1).Borders.LineStyle = xlContinuous
    
97.             r = .Cells(.Rows.Count, 2).End(xlUp).Row + 2
    
98.         Next
    
99.     End With
    
100. End Sub

复制代码