总课表提取班级课表

adud

学校有个总课表,包含各个班级的.我想只要自己的班级的课表,应该怎么做?我试了很久,一直达不到目的,在此求助各位.先谢谢了.下面附件中有数据,表一为总课表,表二为想要达到的目标,只有白天的内容,早晚的没有.

loirol

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         c = .Cells(2, .Columns.Count).End(xlToLeft).Column
   
9.         arr = .Range("a1").Resize(r, c)
   
10.     End With
    
11.     With Worksheets("sheet2")
    
12.         .Cells.Clear
    
13.         r = 1
    
14.         For i = 3 To UBound(arr)
    
15.             With .Cells(r, 1)
    
16.                 .Value = arr(i, 1) & "班课程表"
    
17.                 With .Font
    
18.                     .Name = "微软雅黑"
    
19.                     .Size = 16
    
20.                 End With
    
21.                 .Resize(1, 9).Merge
    
22.             End With
    
23.             .Cells(r + 1, 3).Resize(1, 6) = Array("星期一", "星期二", "星期三", "星期四", "星期五", "星期六")
    
24.             With .Cells(r + 2, 1)
    
25.                 .Value = "早读"
    
26.                 .Resize(2, 1).Merge
    
27.             End With
    
28.             With .Cells(r + 4, 1)
    
29.                 .Value = "上午"
    
30.                 .Resize(5, 1).Merge
    
31.             End With
    
32.             With .Cells(r + 9, 1)
    
33.                 .Value = "下午"
    
34.                 .Resize(5, 1).Merge
    
35.             End With
    
36.             With .Cells(r + 14, 1)
    
37.                 .Value = "晚练"
    
38.                 .Resize(3, 1).Merge
    
39.             End With
    
40.             .Cells(r + 2, 2).Resize(2, 1) = [{1;2}]
    
41.             .Cells(r + 4, 2).Resize(10, 1) = [{1;2;3;4;5;6;7;8;9;10}]
    
42.             .Cells(r + 14, 2).Resize(3, 1) = [{1;2;3}]
    
43.             ReDim brr(1 To 10, 1 To 6)
    
44.             For j = 2 To UBound(arr, 2)
    
45.                 If Len(arr(1, j)) <> 0 Then
    
46.                     n = InStr("一二三四五六", Right(arr(1, j), 1))
    
47.                 End If
    
48.                 m = arr(2, j)
    
49.                 brr(m, n) = arr(i, j)
    
50.             Next
    
51.             .Cells(r + 4, 3).Resize(UBound(brr), UBound(brr, 2)) = brr
    
52.             With .Cells(r + 1, 1).Resize(16, 8)
    
53.                 .Borders.LineStyle = xlContinuous
    
54.             End With
    
55.             r = r + 18
    
56.         Next
    
57.         With .UsedRange
    
58.             .HorizontalAlignment = xlCenter
    
59.             .VerticalAlignment = xlCenter
    
60.         End With
    
61.     End With
    
62. End Sub
    

复制代码

chxw68

详见附件。

adud

chxw68 发表于 2024-12-10 11:50
详见附件。

非常棒,我可以在这个基础上改一改,估计就能达到我要的最终样子了.谢谢

adud

loirol 发表于 2024-12-10 11:44

简单明了,谢谢.比我的复制粘贴高效多了

ykcbf1100

输入班级，提取本班课程

ykcbf1100

参与一下，提取本班课程

1. Sub ykcbf()   '//2024.12.10
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     arr = Sheets("Sheet1").UsedRange
   
5.     For j = 2 To UBound(arr, 2) Step 10
   
6.         st = arr(1, j)
   
7.         For x = 1 To 10
   
8.             For i = 2 To UBound(arr)
   
9.                 s = arr(i, 1) & "|" & arr(1, j) & "|" & x
   
10.                 d(s) = arr(i, j + x - 1)
    
11.             Next
    
12.         Next
    
13.     Next
    
14.     With Sheets("Sheet2")
    
15.         arr = .UsedRange
    
16.         xm = .[b1].Value
    
17.         For j = 3 To UBound(arr, 2)
    
18.             For i = 6 To 15
    
19.                 s = xm & "|" & arr(3, j) & "|" & arr(i, 2)
    
20.                 If d.exists(s) Then
    
21.                     arr(i, j) = d(s)
    
22.                 Else
    
23.                     arr(i, j) = ""
    
24.                 End If
    
25.             Next
    
26.         Next
    
27.         .UsedRange = arr
    
28.     End With
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

cjc209

自定义函数 js框架完成

chxw68

增加了生成某一个班课表的代码。