檢視 Excel VBA/兼代課鐘點費分析的原始碼

<pre>

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
    Dim i1 As Integer
    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.Activate
            sht1.Range(rng1.Offset(i, 1), rng1.Offset(i, 1).End(xlToRight)).Select
            Selection.Copy
            
            
            i1 = rng1.Offset(i, 0).Value - 1
            shtU.Activate
            If rngU.Offset(i1, 0).Value <> rng1.Offset(i, 0).Value Then
                MsgBox ("編號不同，社團編號=" & rng1.Offset(i, 0).Value & "明細編號=" & rngU.Offset(i1, 0).Value)
            End If
            rngU.Offset(i1, 1).Select
            ActiveSheet.Paste
        End If
    
        i = i + 1
    Loop
    
    
    MsgBox ("Total records=" & i)
    ScreenUpdating = True
End Sub

</pre>