课表导出高三任课教师节次表

[vb]代码库

Sub 任课教师节次表()
Dim arr
Dim str As String
Dim i, j, k, m, n
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
str = "高三"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = Worksheets(str & "年级课表")
i = Application.WorksheetFunction.CountA(ws.Rows(1))
arr = Range(ws.Cells(4, 1), ws.Cells(81, i))
'处理括号
arr(1, 1) = "星期": arr(1, 2) = "节次"
For j = 1 To i
If arr(1, j) Like "*（*" Then
arr(1, j) = Replace(Replace(StrConv(arr(1, j), vbNarrow), "(", ""), ")", "")
End If
Next
'提出教师姓名
For j = 2 To UBound(arr)
    For k = 3 To i
        arr(j, k) = Mid(arr(j, k), InStr(arr(j, k), Chr(10)) + 1)
    Next
Next
'处理特殊情况，班会/生态文明等
For j = 1 To i
    If arr(54, j) Like "*/*" Then
    arr(54, j) = Mid(arr(54, j), InStr(arr(54, j), "/") + 1, 10)
    End If
Next
'结果输出
k = 0
For Each ws2 In Sheets
    If ws2.Name = str & "教师" Then
        k = 1
    End If
Next
If k = 1 Then
    Sheets(str & "教师").Delete
End If
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = str & "教师"
Set ws1 = Sheets(str & "教师")
Range(ws1.Cells(1, 1), ws1.Cells(1, i - 1)).Merge
With Range(ws1.Cells(1, 1), ws1.Cells(1, i - 1))
    .Font.Size = 24
    .HorizontalAlignment = xlCenter
End With
ws1.Range("a1") = "开阳一中2020-2021学年度第一学期教师任课节次表（" & str & "年级）"
ws1.Cells(1, i) = Format(Now, "mmdd")
With ws1.Cells(2, 1).Resize(UBound(arr), i)
    .Value = arr
    .Borders.LineStyle = xlContinuous
End With
For j = 57 To 3 Step -1
    If ws1.Cells(j, 2) = "第九节" Or ws1.Cells(j, 2) = "晚自习" Then
        Range("a" & j).EntireRow.Delete
    End If
Next
Range("a48:a69").EntireRow.Delete

For j = 3 To 47
    If Cells(j, 1) <> "" Then
        Range("a" & j & ":a" & j + 8).Merge
    End If
Next
 With Range("a3:a60")
    .Orientation = xlVertical
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
Columns("b:aa").ColumnWidth = 6
Columns("a:a").ColumnWidth = 4
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Call 晚自习
Call 打印设置
End Sub




Sub 晚自习()
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim i, j, k, m, n
Dim arr, brr()
Dim str As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
str = "高三"
Set ws = Sheets("高三年级课表")
For Each ws2 In Sheets
    If ws2.Name = str & "晚" Then
        k = 1
    End If
Next
If k = 1 Then
    Sheets(str & "晚").Delete
End If
ws.Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "高三晚"
Set ws1 = Sheets("高三晚")
ws1.Range("a5:a14").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    For i = 81 To 5 Step -1
        If Cells(i, 1) = "" Or Cells(i, 1).Value = "星期六" Then
            Range("a" & i).EntireRow.Delete
        End If
    Next
Cells(10, 1) = "星期日"
Columns(2).Delete
j = Application.WorksheetFunction.CountA(Rows(1))
Rows(3).Delete
Rows(1).Delete
Cells(2, 1).Value = "星期"
arr = Range(ws1.Cells(2, 1), ws1.Cells(8, j))
For k = 1 To j
If arr(1, k) Like "*（*" Then
arr(1, k) = Replace(Replace(StrConv(arr(1, k), vbNarrow), "(", ""), ")", "")
End If
Next
ReDim brr(1 To 7, 1 To j)

For n = 1 To j
brr(1, n) = arr(1, n)
brr(2, n) = arr(7, n)
For m = 3 To 7
brr(m, n) = arr(m - 1, n)
Next
Next
ws1.Range("a3").Resize(7, j) = brr
ws1.Range("a3").Resize(11, j).Borders.LineStyle = xlContinuous
ws1.Range("a3").Resize(7, j).HorizontalAlignment = xlCenter
ws1.Range("a3").Resize(7, j).VerticalAlignment = xlCenter
Range(ws1.Cells(1, 1), ws1.Cells(1, j)).Merge
With Range(ws1.Cells(1, 1), ws1.Cells(1, j - 1))
    .Font.Size = 20
    .HorizontalAlignment = xlCenter
End With
ws1.Range("a1") = "开阳一中2020-2021学年度第一学期晚自习检查表（" & str & "年级）"
Range(ws1.Cells(2, 1), ws1.Cells(2, j - 1)).Merge
ws1.Range("a2").Font.Size = 14
ws1.Range("a2").HorizontalAlignment = xlCenter
ws1.Cells(2, 1) = "第   周  从   月  日至    月    日"
ws1.Cells(2, j) = Format(Now, "mmdd")
With Range("a4:a9")
    .Orientation = xlVertical
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
Range(Cells(10, 1), Cells(10, j)).Merge
Range(Cells(11, 1), Cells(11, j)).Merge
Range(Cells(12, 1), Cells(12, j)).Merge
Range(Cells(13, 1), Cells(13, j)).Merge

Range(Cells(10, 1), Cells(10, j)).Font.Size = 14
Range("a10") = "备注"

Columns("b:aa").ColumnWidth = 6
Columns("a:a").ColumnWidth = 4
Rows(3).RowHeight = 25
Rows("4:9").RowHeight = 45
Rows("10:13").RowHeight = 30
Application.DisplayAlerts = True
Application.ScreenUpdating = True



Call 打印设置
End Sub

Sub 打印设置()
    Application.PrintCommunication = False '中断打印机的通信
    With ActiveSheet.PageSetup
        .PrintTitleRows = "" '设置打印表头比如= "$1:$2"为设置第一二两行为表头
        .PrintTitleColumns = "" '设置打印左侧重复列数
    End With
    Application.PrintCommunication = True '恢复打印机的通信
    ActiveSheet.PageSetup.PrintArea = "" '打印区域，以字符串的形式= "$A$1:$Y$47"
    Application.PrintCommunication = False '中断打印机的通信
    With ActiveSheet.PageSetup
        .LeftHeader = "" '返回或设置工作簿或节的左页眉上的文本对齐方式。
        .CenterHeader = "" '居中对齐 PageSetup 对象中的页眉信息。可读/写 String 类型。
        .RightHeader = "" '返回或设置页眉的右边部分内容。可读/写 String 类型。
        .LeftFooter = "" '返回或设置工作簿或节的左页脚上的文本对齐方式。
        .CenterFooter = "" '居中对齐 PageSetup 对象中的页脚信息。可读/写 String 类型。
'（磅：指打印的字符的高度的度量单位。1 磅等于 1/72 英寸，或大约等于 1 厘米的 1/28。）
        .RightFooter = "" '返回或设置页面右边缘与页脚右边界之间的距离（以磅为单位）。可读/写 String 类型
        .LeftMargin = Application.InchesToPoints(0) '以磅为单位返回或设置左边距的大小。Double 类型，可读写。
        .RightMargin = Application.InchesToPoints(0) '以磅 为单位返回或设置右边距的大小。Double 类型，可读写。
        .TopMargin = Application.InchesToPoints(0.393700787401575) '以磅 为单位返回或设置上边距的大小。Double 类型，可读写。
        .BottomMargin = Application.InchesToPoints(0) '以磅 为单位返回或设置底端边距的大小。Double 类型，可读写。
        .HeaderMargin = Application.InchesToPoints(0) '以磅为单位返回或设置页面顶端到页眉的距离。Double 类型，可读写。
        .FooterMargin = Application.InchesToPoints(0) '以磅 为单位返回或设置页脚到页面底端的距离。Double 类型，可读写。
        .PrintHeadings = False '如果打印本页时同时打印行标题和列标题，则该值为 True。仅应用于工作表。Boolean 类型，可读写。
        .PrintGridlines = False '如果在页面上打印单元格网格线，则该值为 True。仅应用于工作表。Boolean 类型，可读写。
        .PrintComments = xlPrintNoComments '返回或设置批注随工作表打印的方式。XlPrintLocation 类型，可读写。
        .PrintQuality = 600 '返回或设置打印质量。Variant 类型，可读写。
        .CenterHorizontally = True '水平居中为true，不选则为false
        .CenterVertically = False '垂直居中为true，不选则为false
        .Orientation = xlLandscape '横向打印，纵向为xlPortrait
        .Draft = False '如果打印工作表时不打印其中的图形，则该属性值为 True。Boolean 类型，可读写。
        .PaperSize = xlPaperA4 '返回或设置纸张大小。可读写 XlPaperSize。
        .FirstPageNumber = xlAutomatic '返回或设置打印指定工作表时第一页的页号。如果设为 xlAutomatic，则 Microsoft Excel 采用第一页的页号。默认值为 xlAutomatic。Long 类型，可读写。
        .Order = xlDownThenOver '返回或设置一个 XlOrder 值，该值代表 Microsoft Excel 打印一张大工作表时用于对页进行编号的顺序。
        .BlackAndWhite = False '如果指定文档中的元素以黑白方式打印，则该属性值为 True。Boolean 类型，可读写。
        .Zoom = False '自动缩放，它代表一个数值在 10% 到 400% 之间的百分比，也可以直接=95即为缩放到原来的95%
        .FitToPagesWide = 1 '调整为1页
        .FitToPagesTall = 1 '调整为1页高,=false时为N页高
        .PrintErrors = xlPrintErrorsDisplayed '设置或返回一个 XlPrintErrors 常量，该常量指定显示的打印错误类型。该功能允许用户在打印工作表时取消错误显示。可读写。
        .OddAndEvenPagesHeaderFooter = False '如果指定的 PageSetup 对象的奇数页和偶数页具有不同的页眉和页脚，则该属性值为 True。Boolean 类型，可读写。
        .DifferentFirstPageHeaderFooter = False '如果在第一页使用不同的页眉或页脚，则为 True。可读/写 Boolean 类型。
        .ScaleWithDocHeaderFooter = True '返回或设置页眉和页脚是否在文档大小更改时随文档缩放。可读/写 Boolean 类型。
        .AlignMarginsHeaderFooter = True '如果 Excel 以页面设置选项中设置的边距对齐页眉和页脚，则返回 True。可读/写 Boolean 类型。
 
    End With
    Application.PrintCommunication = True '恢复打印机的通信
End Sub