Excel VBA/兼代課鐘點費分析

Sub Replace6by7()
'   社團週，把班週會改為社團活動
'   正確的資料結構很重要，本程式會檢查資料旳結構的合理性
'   以2017年10月30日(一)至12月1日(五)而言，共跨5週，分別為第10-14週
'   其中第10,11,13週為社團週
'   每班在調代課系統的課表中，在此3週的每一週必各有一節社團活動課，和一節班週會課。
'   然而，實際上課情況不同於調代課系統中的課表。在社團週，實際上課會把班週會的課，會用來上社團課。
'       而形成連上兩節社團課。
'   反之，在班週會週，就會連上兩節班週會。
'   輸入資料必須經過適當排列，排列順序為
'       1) 班級 由小到大
'       2) 週次 由小到大
'       3) 星期 由小到大
'       4) 節次 由大到小，因為社團在第7節，而班週會在第6節

    Dim sht1 As Worksheet
    Dim rng1 As Range
    Dim i As Integer
    Dim strClass As String
    Dim strWeek As String
    Dim strDay As String
    Dim strPeriod As String
    Const conClass = 9
    Const conWeek = 6
    Const conDay = 7
    Const conPeriod = 8
    Dim nDay As Integer
    Dim nWeek As Integer
    Dim nClass As Integer
    
    
    
    ScreenUpdating = False
    Set sht1 = Worksheets("第101113週")
    Set rng1 = sht1.Range("A2")
    i = 0
    nClass = 0
    Do Until rng1.Offset(i, 0).Value = ""
        strClass = rng1.Offset(i, conClass).Value
        nWeek = 0
        Do Until (strClass <> rng1.Offset(i, conClass).Value) Or (rng1.Offset(i, 0).Value = "")
            strWeek = rng1.Offset(i, conWeek).Value
            nDay = 0
            Do Until strWeek <> rng1.Offset(i, conWeek).Value Or _
                    (strClass <> rng1.Offset(i, conClass).Value) Or (rng1.Offset(i, 0).Value = "")
                strDay = rng1.Offset(i, conDay).Value
                Do Until (strDay <> rng1.Offset(i, conDay).Value) Or (strWeek <> rng1.Offset(i, conWeek).Value) Or _
                    (strClass <> rng1.Offset(i, conClass).Value) Or (rng1.Offset(i, 0).Value = "")
                    strPeriod = rng1.Offset(i + 1, conPeriod).Value
                    Range(rng1.Offset(i, 1), rng1.Offset(i, 1).End(xlToRight)).Select
                    Selection.Copy
                    rng1.Offset(i + 1, 1).Select
                    ActiveSheet.Paste
                    rng1.Offset(i + 1, conPeriod).Value = strPeriod
'                   跳一列
                     i = i + 2
                Loop
                strDay = rng1.Offset(i, conDay).Value
                nDay = nDay + 1
            Loop
            If nDay <> 1 Then
                MsgBox ("nDay error=" & nDay)
            End If
            strWeek = rng1.Offset(i, conWeek).Value
            nWeek = nWeek + 1
        Loop
        If nWeek <> 3 Then
            MsgBox ("nWeek error=" & nWeek)
        End If
        strClass = rng1.Offset(i, conClass).Value
        nClass = nClass + 1
    Loop
    MsgBox ("nClass =" & nClass)
    MsgBox ("Total records=" & i)
    ScreenUpdating = True
End Sub

Sub Replace7by6()
'   班週會週，把社團活動改為班週會
'   正確的資料結構很重要，本程式會檢查資料旳結構的合理性
'   以2017年10月30日(一)至12月1日(五)而言，共跨5週，分別為第10-14週
'   其中第12,14週為社團週
'   每班在調代課系統的課表中，在此2週的每一週必各有一節社團活動課，和一節班週會課。
'   然而，實際上課情況不同於調代課系統中的課表。在班週會週，實際上課會把社團的課，會用來上班週會。
'       而形成連上兩節班週會課。
'   反之，在社團週，就會連上兩節社團課。

'   輸入資料必須經過適當排列，排列順序為
'       1) 班級 由小到大
'       2) 週次 由小到大
'       3) 星期 由小到大
'       4) 節次 由小到大，因為社團在第6節，而班週會在第7節


    Dim sht1 As Worksheet
    Dim rng1 As Range
    Dim i As Integer
    Dim strClass As String
    Dim strWeek As String
    Dim strDay As String
    Dim strPeriod As String
    Const conClass = 9
    Const conWeek = 6
    Const conDay = 7
    Const conPeriod = 8
    Dim nDay As Integer
    Dim nWeek As Integer
    Dim nClass As Integer
    
    
    
    ScreenUpdating = False
    Set sht1 = Worksheets("第1214週")
    Set rng1 = sht1.Range("A2")
    i = 0
    nClass = 0
    Do Until rng1.Offset(i, 0).Value = ""
        strClass = rng1.Offset(i, conClass).Value
        nWeek = 0
        Do Until (strClass <> rng1.Offset(i, conClass).Value) Or (rng1.Offset(i, 0).Value = "")
            strWeek = rng1.Offset(i, conWeek).Value
            nDay = 0
            Do Until strWeek <> rng1.Offset(i, conWeek).Value Or _
                    (strClass <> rng1.Offset(i, conClass).Value) Or (rng1.Offset(i, 0).Value = "")
                strDay = rng1.Offset(i, conDay).Value
                Do Until (strDay <> rng1.Offset(i, conDay).Value) Or (strWeek <> rng1.Offset(i, conWeek).Value) Or _
                    (strClass <> rng1.Offset(i, conClass).Value) Or (rng1.Offset(i, 0).Value = "")
                    strPeriod = rng1.Offset(i + 1, conPeriod).Value
                    Range(rng1.Offset(i, 1), rng1.Offset(i, 1).End(xlToRight)).Select
                    Selection.Copy
                    rng1.Offset(i + 1, 1).Select
                    ActiveSheet.Paste
                    rng1.Offset(i + 1, conPeriod).Value = strPeriod
'                   跳一列
                     i = i + 2
                Loop
                strDay = rng1.Offset(i, conDay).Value
                nDay = nDay + 1
            Loop
            If nDay <> 1 Then
                MsgBox ("nDay error=" & nDay)
            End If
            strWeek = rng1.Offset(i, conWeek).Value
            nWeek = nWeek + 1
        Loop
        If nWeek <> 3 Then
            MsgBox ("nWeek error=" & nWeek)
        End If
        strClass = rng1.Offset(i, conClass).Value
        nClass = nClass + 1
    Loop
    MsgBox ("nClass =" & nClass)
    MsgBox ("Total records=" & i)
    ScreenUpdating = True
End Sub

Sub AjustClass()
'   將社團週和班週會週調整過的資料寫回原始資料
'   本程式輸入兩個表，更新一個表
'       輸入一：社團週
'       輸入二：班週會週
'       更新：明細
'   更新之明細表必須經過適當排列，排列順序為「編號」由小到大
'   輸入一、二表之編號，可用來作為更新表之列的 Offset

    Dim sht1 As Worksheet
    Dim sht2 As Worksheet
    Dim shtU As Worksheet

    Dim rng1 As Range
    Dim rng2 As Range
    Dim rngU As Range
    Const conPeriod = 8
    
    ScreenUpdating = False
    
    Set sht1 = Worksheets("第101113週") '社團週
'    Set sht2 = Worksheets("第1214週")   '班週會週
    Set shtU = Worksheets("明細")  '明細
    
    
    
    Set rng1 = sht1.Range("A2")
    Set rngU = shtU.Range("A2")
    
    i = 0
    Do Until rng1.Offset(i, 0).Value = ""
        If rng1.Offset(i, conPeriod).Value = 6 Then
        
            sht1.Range(rng1.Offset(i, 1), rng1.Offset(i, 1).End(xlToRight)).Select
            Selection.Copy
            
            shtU.rngU.Offset(sht1.rng1.Offset(i, 0), 1).Select
            ActiveSheet.Paste
            
        End If
    
        i = i + 1
    Loop
    
    
    MsgBox ("nClass =" & nClass)
    MsgBox ("Total records=" & i)
    ScreenUpdating = True
End Sub