補考名單通知教師

2018.05.31 註冊組希望有這個功能，但是可能其他人要用到機會不大吧！檔案不大，會直接列印如下圖，所有姓名都已變造以保護個資，檔案內也有執行說明：

原始碼：

Dim 列印暫存列號 As Integer
Dim 列號 As Integer
Dim 頁數 As Integer
Sub 列印補行評量成績通知()
    Sheets("空白補行評量成績").Select
    頁數 = 頁數 - 1
    ActiveWindow.SelectedSheets.PrintOut From:=1, to:=頁數, Copies:=1, Collate _
        :=True, IgnorePrintAreas:=False
End Sub
Sub 主程式()
    Call 填入列印暫存
    Sheets("補行評量暫存").Select
    Call 資料排序
    Call 填入列印
    Call 列印補行評量成績通知
    Sheets("列印及說明").Select
End Sub
Sub 填入列印暫存()
    Call 清除舊資料
    Sheets("三下補考名單 (非學科)").Select
    列號 = 2
    列印暫存列號 = 2
    Do While 1 = 1
        If Cells(列號, "O").Value >= 60 And Cells(列號, "P").Value >= 60 And Cells(列號, "Q").Value >= 60 Then
            Exit Do
        End If
        If Cells(列號, "O").Value < 60 Then
            If Cells(列號, "S").Value < 60 Then
                Call 填入單筆("A", "O", "S")
            End If
            If Cells(列號, "T").Value < 60 Then
                Call 填入單筆("B", "O", "T")
            End If
        End If
        If Cells(列號, "P").Value < 60 Then
            If Cells(列號, "U").Value < 60 Then
                Call 填入單筆("C", "P", "U")
            End If
            If Cells(列號, "V").Value < 60 Then
                Call 填入單筆("D", "P", "V")
            End If
            If Cells(列號, "W").Value < 60 Then
                Call 填入單筆("E", "P", "W")
            End If
        End If
        If Cells(列號, "Q").Value < 60 Then
            Call 填入單筆("F", "Q", "Q")
        End If
        列號 = 列號 + 1
    Loop
End Sub
Sub 填入單筆(教師, 領域, 科目)
    Sheets("補行評量暫存").Cells(列印暫存列號, "A").Value = Cells(列號, 教師).Value
    Sheets("補行評量暫存").Cells(列印暫存列號, "B").Value = Cells(列號, "H").Value
    Sheets("補行評量暫存").Cells(列印暫存列號, "C").Value = Cells(列號, "I").Value
    Sheets("補行評量暫存").Cells(列印暫存列號, "D").Value = Cells(列號, "J").Value
    Sheets("補行評量暫存").Cells(列印暫存列號, "E").Value = Cells(列號, 領域).Value
    Sheets("補行評量暫存").Cells(列印暫存列號, "F").Value = Cells(列號, 科目).Value
    Sheets("補行評量暫存").Cells(列印暫存列號, "G").Value = Cells(1, 教師).Value
    Sheets("補行評量暫存").Cells(列印暫存列號, "H").Value = Cells(1, 領域).Value
    Sheets("補行評量暫存").Cells(列印暫存列號, "I").Value = Cells(1, 科目).Value
    列印暫存列號 = 列印暫存列號 + 1
End Sub
Sub 清除舊資料()
    Sheets("補行評量暫存").Select
    Range("A2:I500").Select
    Selection.ClearContents
End Sub
Sub 資料排序()
    排序號 = 列印暫存列號 - 1
    Cells.Select
    ActiveWorkbook.Worksheets("補行評量暫存").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("補行評量暫存").Sort.SortFields.Add Key:=Range("A2", Cells(排序號, "A")) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("補行評量暫存").Sort.SortFields.Add Key:=Range("G2", Cells(排序號, "G")) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("補行評量暫存").Sort
        .SetRange Range("A1", Cells(排序號, "I"))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Sub 填入列印()
    Call 清除空白補行評量成績
    頁數 = 1
    每頁序 = 1
    ' 1頁最多15筆
    For i = 1 To 列印暫存列號 - 1
        If i = 1 Then
            Call 填入表頭(1, 2)
            Call 填入列印內容(2, 2)
            每頁序 = 2
        Else
            If (Sheets("補行評量暫存").Cells(i, "A").Value = Sheets("補行評量暫存").Cells(i + 1, "A").Value) And 每頁序 < 16 Then
                Call 填入列印內容(頁數 * 19 - 19 + 每頁序 + 1, i + 1)
                每頁序 = 每頁序 + 1
            Else
                頁數 = 頁數 + 1
                Sheets("空白補行評量成績").Cells(頁數 * 19 - 1, "A").Value = Sheets("空白補行評量成績").Cells(18, "A").Value
                Call 填入表頭(頁數 * 19 - 18, i + 1)
                Call 填入列印內容(頁數 * 19 - 17, i + 1)
                每頁序 = 2
            End If
        End If
    Next i
End Sub
Sub 填入表頭(列印列號, 暫存列號)
    Sheets("空白補行評量成績").Cells(列印列號, "A").Value = Sheets("補行評量暫存").Cells(暫存列號, "G").Value
    Sheets("空白補行評量成績").Cells(列印列號, "E").Value = Sheets("補行評量暫存").Cells(暫存列號, "H").Value
    Sheets("空白補行評量成績").Cells(列印列號, "F").Value = Sheets("補行評量暫存").Cells(暫存列號, "I").Value
End Sub
Sub 填入列印內容(列印列號, 暫存列號)
    Sheets("空白補行評量成績").Cells(列印列號, "A").Value = Sheets("補行評量暫存").Cells(暫存列號, "A").Value
    Sheets("空白補行評量成績").Cells(列印列號, "B").Value = Sheets("補行評量暫存").Cells(暫存列號, "B").Value
    Sheets("空白補行評量成績").Cells(列印列號, "C").Value = Sheets("補行評量暫存").Cells(暫存列號, "C").Value
    Sheets("空白補行評量成績").Cells(列印列號, "D").Value = Sheets("補行評量暫存").Cells(暫存列號, "D").Value
    Sheets("空白補行評量成績").Cells(列印列號, "E").Value = Sheets("補行評量暫存").Cells(暫存列號, "E").Value
    Sheets("空白補行評量成績").Cells(列印列號, "F").Value = Sheets("補行評量暫存").Cells(暫存列號, "F").Value
    Range(Cells(列印列號, "A"), Cells(列印列號, "G")).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
Sub 清除空白補行評量成績()
    Sheets("空白補行評量成績").Select
    For i = 1 To 20
        Range(Cells(i * 19 - 17, "A"), Cells(i * 19 - 3, "G")).Select
        Selection.ClearContents
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeTop).LineStyle = xlNone
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Next i
End Sub