课表的拆分与合并

yangfx16900

用VBA来对课表进行拆分与合并，具体要求在各个Excel表中。

chxw68

个人课表代码：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   If Target.Count > 1 Then
   
5.     Exit Sub
   
6.   End If
   
7.   If Target.Address = "$N$1" Then
   
8.     With Worksheets("机房课表")
   
9.       arr = .Range("b3:p30")
   
10.       ReDim brr(1 To 7, 1 To 10)
    
11.       m = 0
    
12.       For i = 1 To UBound(arr) Step 4
    
13.         m = m + 1
    
14.         n = -1
    
15.         For j = 1 To UBound(arr, 2) Step 3
    
16.           n = n + 2
    
17.           For k = 1 To 4
    
18.             If arr(i + k - 1, j + 1) = Target.Value Then
    
19.               brr(m, n) = arr(i + k - 1, j)
    
20.               brr(m, n + 1) = arr(i + k - 1, j + 2)
    
21.             End If
    
22.           Next
    
23.         Next
    
24.       Next
    
25.     End With
    
26.     With Worksheets("个人课表")
    
27.       .Range("b3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
28.     End With
    
29.   End If
    
30. End Sub
    

复制代码

chxw68

单机房课表代码：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   If Target.Count > 1 Then
   
5.     Exit Sub
   
6.   End If
   
7.   If Target.Address = "$N$1" Then
   
8.     With Worksheets("机房课表")
   
9.       arr = .Range("b3:p30")
   
10.       ReDim brr(1 To 7, 1 To 10)
    
11.       m = 0
    
12.       For i = 1 To UBound(arr) Step 4
    
13.         m = m + 1
    
14.         n = -1
    
15.         For j = 1 To UBound(arr, 2) Step 3
    
16.           n = n + 2
    
17.           For k = 1 To 4
    
18.             If arr(i + k - 1, j + 2) = Target.Value Then
    
19.               brr(m, n) = arr(i + k - 1, j)
    
20.               brr(m, n + 1) = arr(i + k - 1, j + 1)
    
21.             End If
    
22.           Next
    
23.         Next
    
24.       Next
    
25.     End With
    
26.     With Worksheets("单机房课表")
    
27.       .Range("b3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
28.     End With
    
29.   End If
    
30. End Sub
    
31. 
    

复制代码

chxw68

班级课表：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   If Target.Count > 1 Then
   
5.     Exit Sub
   
6.   End If
   
7.   If Target.Address = "$N$1" Then
   
8.     With Worksheets("机房课表")
   
9.       arr = .Range("b3:p30")
   
10.       ReDim brr(1 To 7, 1 To 10)
    
11.       m = 0
    
12.       For i = 1 To UBound(arr) Step 4
    
13.         m = m + 1
    
14.         n = -1
    
15.         For j = 1 To UBound(arr, 2) Step 3
    
16.           n = n + 2
    
17.           For k = 1 To 4
    
18.             If arr(i + k - 1, j) = Target.Value Then
    
19.               brr(m, n) = arr(i + k - 1, j + 1)
    
20.               brr(m, n + 1) = arr(i + k - 1, j + 2)
    
21.             End If
    
22.           Next
    
23.         Next
    
24.       Next
    
25.     End With
    
26.     With Worksheets("班级课表")
    
27.       .Range("b3").Resize(UBound(brr), UBound(brr, 2)) = brr
    
28.     End With
    
29.   End If
    
30. End Sub

复制代码

chxw68

最后一个问题没有看明白。

yangfx16900

EH高手如云，真是学习的好地方！

yangfx16900

chxw68 发表于 2019-3-14 09:32
最后一个问题没有看明白。

最后一张表，就是想办法让每一位老师的课表，汇总到一张表上去，如同第一张表的样式，但并不完全一样，不一样的地方是，汇总后，使得星期相同、节次相同的不同教师进入同一个单元格，星期相同、节次相同的不同班级、进入同一个单元格，星期相同、节次相同的不同机房名进入同一个单元格。

chxw68

yangfx16900 发表于 2019-3-14 10:34
最后一张表，就是想办法让每一位老师的课表，汇总到一张表上去，如同第一张表的样式，但并不完全一样，不 ...

应该跟第一张表一样，只是把诸多内容放到一个单元格内？