關於發展報告的相關檔案生成的源程式

weixin_30488085發表於2020-04-06

按照要求,發展報告中的資料檔案共有9個:

image

程式實現的目標是對xx檔案,要按照省定的課程要求,自動生成表中所要求的資料,並且合格,達到學生學分畢業的要求.其餘9個檔案,是屬於班主任負責填寫,只需要收齊後自動合併成一個大表便於資料處理就可.

目標要求:自動生成3個年級對應的資料夾,並在一級資料夾下建立二級資料夾(分文理科),以便於下面資料的處理.

源程式如下:

Option Explicit
Option Base 1
Sub AA01按班生成對應班級資料夾()
    Dim i As Integer, j As Integer, k As Integer, bjS As Integer
    Dim xxRs() As Integer, totalR As Integer, xxXx() As Variant
    Dim wenli(2) As String, nj As Integer
    '首先刪除指定資料夾下的所有子目錄,便於後續程式的執行
    '其次按指定班號建立對應子目錄
    bjS = 20 '共20個班,根據需要自行修改,但要求為連續班號
    ReDim xxRs(bjS)
    For i = 1 To bjS
        '刪除bzhr目錄下的原有目錄及檔案,並重新建立新目錄
        With Application.FileSearch
            .NewSearch
            .LookIn = ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
            .SearchSubFolders = True
            .Filename = "*.*"
            .MatchAllWordForms = True
            .FileType = msoFileTypeAllFiles
            If .Execute() > 0 Then
                For j = 1 To .FoundFiles.Count
                    Kill .FoundFiles(j)
                Next j
                RmDir ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
                MkDir ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
            Else
                If Dir(ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)), vbDirectory) = vbNullString Then
                    MkDir ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
                End If
            End If
        End With
    Next i
End Sub
Sub AA02刪除xx下的所有檔案並重建子資料夾()
    Dim i As Integer, j As Integer, k As Integer, bjS As Integer
    Dim xxRs() As Integer, totalR As Integer, xxXx() As Variant
    Dim wenli(2) As String, nj As Integer
    '刪除xx目錄下的所有檔案
    wenli(1) = "文"
    wenli(2) = "理"
    For nj = 1 To 3
        If nj >= 2 Then
            For k = 1 To 2
                With Application.FileSearch
                    .NewSearch
                    .LookIn = ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(k)
                    .SearchSubFolders = True
                    .Filename = "*.*"
                    .MatchAllWordForms = True
                    .FileType = msoFileTypeAllFiles
                    If .Execute() > 0 Then
                        For j = 1 To .FoundFiles.Count
                            Kill .FoundFiles(j)
                        Next j
                        RmDir ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(k)
                        MkDir ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(k)
                    Else
                        If Dir(ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(k), vbDirectory) = vbNullString Then
                            MkDir ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(k)
                        End If
                    End If
                End With
            Next k
        Else
            With Application.FileSearch
                .NewSearch
                .LookIn = ThisWorkbook.Path & "\xx\高" & Trim(Str(nj))
                .SearchSubFolders = True
                .Filename = "*.*"
                .MatchAllWordForms = True
                .FileType = msoFileTypeAllFiles
                If .Execute() > 0 Then
                    For j = 1 To .FoundFiles.Count
                        Kill .FoundFiles(j)
                    Next j
                    RmDir ThisWorkbook.Path & "\xx\高" & Trim(Str(nj))
                    MkDir ThisWorkbook.Path & "\xx\高" & Trim(Str(nj))
                Else
                    If Dir(ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)), vbDirectory) = vbNullString Then
                        MkDir ThisWorkbook.Path & "\xx\高" & Trim(Str(nj))
                    End If
                End If
            End With
        End If
    Next nj
End Sub

建立後的截圖如下:

image

image

考慮到一次集中處理的是3個年級對應的1個學期(即1/3/5或2/4/6學期),所以一併處理即可.

Option Base 1
Sub A生成各模組學分檔案()
    Dim i As Integer, totalR As Integer, arrxs(), rdsj As String, xueqi As String
    Dim xsRS As Integer, arrxiangmu(), j As Integer, wl As Integer, nj As Integer
    Dim arr1(), k As Integer
    Dim arr2(), arr3(), arr(), wenli(3) As String
    Dim m As Integer, RngK As Integer, RngB As Integer
    wenli(1) = "文"
    wenli(2) = "理"
    wenli(3) = ""
    rdsj = "20120130" '認定時間
    xueqi = 1 '高1學期,據此自動修改高2/高3對應學期
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    '獲取需要參與資料處理的學生名單 arrxs()為學生學籍號及名單,共2列.
    For nj = 1 To 3
        If nj >= 2 Then '區分年級,高2/高3分文理
            For wl = 1 To 2 '文理科,1文2理.
                Workbooks("源程式").Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                Columns(3).NumberFormat = "0"
                xsRS = Range("A65536").End(xlUp).Row
                arrxs() = Range(Cells(2, 1), Cells(xsRS, 2))
                '獲取學分建立所需的模組程式碼
                Sheets(Trim("領域及模組" & Trim(Str(nj)) & wenli(wl))).Activate
                totalR = Range("A65536").End(xlUp).Row '獲取總模組數,以便建立迴圈操作
                ReDim arrxiangmu(UBound(arrxs), 11)  '定義二維資料,儲存每個學生的每個模組的11項資料
                For i = 2 To totalR
                    '提前填充固定資料
                    For m = 1 To UBound(arrxs)
                        Select Case Left(Cells(i, 1).Value, 2)
                            Case "08"
                                arrxiangmu(m, 1) = "A"
                            Case Else
                                arrxiangmu(m, 1) = Trim(Str(Int((100 - 61 + 1) * Rnd + 61)))
                        End Select
                        arrxiangmu(m, 2) = Trim(Str(Cells(i, 8).Value))  '學分
                        arrxiangmu(m, 3) = Cells(i, 3).Value   '科目編號
                        arrxiangmu(m, 4) = Cells(i, 1).Value  '模組編號
                        arrxiangmu(m, 5) = nj  '學年.
                        '解決學校模組名稱的判斷填充問題
                        Select Case Left(Cells(i, 1).Value, 6)
                            Case "070011", "080010", "080020", "080030", "090011", "090021"
                                arrxiangmu(m, 10) = Cells(i, 2).Value
                        End Select
                        '解決選修II學習方式的判斷填充問題
                        If Left(Cells(i, 3).Value, 2) = "09" Then
                            arrxiangmu(m, 6) = "2"
                        Else
                            If Cells(i, 5).Value = "選修" Then
                                arrxiangmu(m, 6) = "1"     '選修
                            Else
                                arrxiangmu(m, 6) = "0"     '必修
                            End If
                        End If
                        arrxiangmu(m, 7) = Cells(i, 6).Value  '考核方式
                        arrxiangmu(m, 8) = Trim(Str(Cells(i, 7).Value))  '學時
                        arrxiangmu(m, 9) = rdsj  '學分認定時間
                        arrxiangmu(m, 11) = xueqi + (nj - 1) * 2 '學期資料,請自行修改
                    Next m
                    '按學科建立對應學分檔案
                    FileCopy ThisWorkbook.Path & "\樣表\xx.xls", ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(wl) & "\xx" & Trim(Cells(i, 1).Value) & ".xls"
                    Debug.Print wenli(wl) & "科共" & totalR - 1 & "個學分檔案,已完成" & i - 1 & "個."
                    '開啟學分檔案進行固定資料填充
                    Workbooks.Open ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(wl) & "\xx" & Trim(Cells(i, 1).Value) & ".xls"
                    Cells(2, 1).Resize(UBound(arrxs), 13).NumberFormatLocal = "@"
                    Range(Cells(2, 1), Cells(UBound(arrxs) + 1, 2)).Value = arrxs
                    For j = 1 To 9
                        Range(Cells(2, j + 2), Cells(UBound(arrxs) + 1, j + 2)).Value = Application.WorksheetFunction.Index(arrxiangmu, 0, j)
                    Next j
                    Range(Cells(2, 14), Cells(UBound(arrxs) + 1, 14)).Value = Application.WorksheetFunction.Index(arrxiangmu, 0, 11)
                    Range(Cells(2, 13), Cells(UBound(arrxs) + 1, 13)).Value = Application.WorksheetFunction.Index(arrxiangmu, 0, 10)
                    ActiveWorkbook.Close savechanges:=True
                    Workbooks("源程式").Sheets(Trim("領域及模組" & Trim(Str(nj)) & wenli(wl))).Activate
                Next i
                '填充每位學生每個模組的任課教師姓名
                '將模組名稱填充到第一行作為標題.
                arr1() = Range(Cells(2, 1), Cells(totalR, 1)).Value
                Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                Range(Cells(1, 4), Cells(1, 4)).Resize(1, UBound(arr1)).NumberFormatLocal = "@"
                Range(Cells(1, 4), Cells(1, 4)).Resize(1, UBound(arr1)).Value = Application.WorksheetFunction.Transpose(arr1) '水平轉置
                ReDim arr1(totalR - 1)
                ReDim arr2(UBound(arrxs))
                ReDim arr3(UBound(arrxs))
                '獲取所有學模組編號前5位
                For j = 1 To UBound(arr1)
                    arr1(j) = Left(Cells(1, j + 3).Value, 5)
                Next j
                '獲取所有學生的班級,利用arr3()儲存對應任課教師.
                For i = 1 To xsRS - 1
                    arr2(i) = Cells(i + 1, 3).Value
                Next i
                '按班級提取對應模組的任課教師姓名
                Sheets(Trim("教師名單" & Trim(Str(nj)))).Activate
                For RngK = 2 To Range("A65536").End(xlUp).Row
                    For j = 1 To UBound(arr1)
                        If Cells(RngK, 1).Value = arr1(j) Then
                            For RngB = 2 To Range("IV1").End(xlToLeft).Column
                                For i = 1 To xsRS - 1
                                    If arr2(i) = Cells(1, RngB) Then
                                        arr3(i) = Cells(RngK, RngB).Value
                                        Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                                        Cells(i + 1, j + 3).Value = arr3(i)
                                        Sheets(Trim("教師名單" & Trim(Str(nj)))).Activate
                                    End If
                                Next i
                            Next RngB
                        End If
                    Next j
                Next RngK
                '將任課教師姓名填充至對應模組學分檔案中.
                ReDim arr1(xsRS - 1)
                For j = 1 To totalR - 1
                    Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                    arr1() = Cells(2, j + 3).Resize(UBound(arr1), 1).Value
                    Workbooks.Open ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(wl) & "\xx" & Trim(Cells(1, j + 3).Value) & ".xls"
                    Cells(2, 12).Resize(UBound(arr1), 1).Value = arr1
                    ActiveWorkbook.Close savechanges:=True
                Next j
                Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                Range(Cells(1, 4), Cells(Range("A65536").End(xlUp).Row, Range("IV1").End(xlToLeft).Column + 1)).Clear
            Next wl
        Else '高1年級單獨處理
            For wl = 3 To 3
                Workbooks("源程式").Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                Columns(3).NumberFormat = "0"
                xsRS = Range("A65536").End(xlUp).Row
                arrxs() = Range(Cells(2, 1), Cells(xsRS, 2))
                '獲取學分建立所需的模組程式碼
                Sheets(Trim("領域及模組" & Trim(Str(nj)) & wenli(wl))).Activate
                totalR = Range("A65536").End(xlUp).Row '獲取總模組數,以便建立迴圈操作
                ReDim arrxiangmu(UBound(arrxs), 11)  '定義二維資料,儲存每個學生的每個模組的11項資料
                For i = 2 To totalR
                    '提前填充固定資料
                    For m = 1 To UBound(arrxs)
                        Select Case Left(Cells(i, 1).Value, 2)
                            Case "08"
                                arrxiangmu(m, 1) = "A"
                            Case Else
                                arrxiangmu(m, 1) = Trim(Str(Int((100 - 61 + 1) * Rnd + 61)))
                        End Select
                        arrxiangmu(m, 2) = Trim(Str(Cells(i, 8).Value))  '學分
                        arrxiangmu(m, 3) = Cells(i, 3).Value   '科目編號
                        arrxiangmu(m, 4) = Cells(i, 1).Value  '模組編號
                        arrxiangmu(m, 5) = nj  '學年.
                        '解決學校模組名稱的判斷填充問題
                        Select Case Left(Cells(i, 1).Value, 6)
                            Case "070011", "080010", "080020", "080030", "090011", "090021"
                                arrxiangmu(m, 10) = Cells(i, 2).Value
                        End Select
                        '解決選修II學習方式的判斷填充問題
                        If Left(Cells(i, 3).Value, 2) = "09" Then
                            arrxiangmu(m, 6) = "2"
                        Else
                            If Cells(i, 5).Value = "選修" Then
                                arrxiangmu(m, 6) = "1"     '選修
                            Else
                                arrxiangmu(m, 6) = "0"     '必修
                            End If
                        End If
                        arrxiangmu(m, 7) = Cells(i, 6).Value  '考核方式
                        arrxiangmu(m, 8) = Trim(Str(Cells(i, 7).Value))  '學時
                        arrxiangmu(m, 9) = rdsj  '學分認定時間,請自行修改
                        arrxiangmu(m, 11) = xueqi + (nj - 1) * 2 '學期資料,請自行修改
                    Next m
                    '按學科建立對應學分檔案
                    FileCopy ThisWorkbook.Path & "\樣表\xx.xls", ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(wl) & "\xx" & Trim(Cells(i, 1).Value) & ".xls"
                    Debug.Print wenli(wl) & "科共" & totalR - 1 & "個學分檔案,已完成" & i - 1 & "個."
                    '開啟學分檔案進行固定資料填充
                    Workbooks.Open ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\" & wenli(wl) & "\xx" & Trim(Cells(i, 1).Value) & ".xls"
                    Cells(2, 1).Resize(UBound(arrxs), 13).NumberFormatLocal = "@"
                    Range(Cells(2, 1), Cells(UBound(arrxs) + 1, 2)).Value = arrxs
                    For j = 1 To 9
                        Range(Cells(2, j + 2), Cells(UBound(arrxs) + 1, j + 2)).Value = Application.WorksheetFunction.Index(arrxiangmu, 0, j)
                    Next j
                    Range(Cells(2, 14), Cells(UBound(arrxs) + 1, 14)).Value = Application.WorksheetFunction.Index(arrxiangmu, 0, 11)
                    Range(Cells(2, 13), Cells(UBound(arrxs) + 1, 13)).Value = Application.WorksheetFunction.Index(arrxiangmu, 0, 10)
                    ActiveWorkbook.Close savechanges:=True
                    Workbooks("源程式").Sheets(Trim("領域及模組" & Trim(Str(nj)) & wenli(wl))).Activate
                Next i
                '填充每位學生每個模組的任課教師姓名
                '將模組名稱填充到第一行作為標題.
                arr1() = Range(Cells(2, 1), Cells(totalR, 1)).Value
                Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                Range(Cells(1, 4), Cells(1, 4)).Resize(1, UBound(arr1)).NumberFormatLocal = "@"
                Range(Cells(1, 4), Cells(1, 4)).Resize(1, UBound(arr1)).Value = Application.WorksheetFunction.Transpose(arr1) '水平轉置
                ReDim arr1(totalR - 1)
                ReDim arr2(UBound(arrxs))
                ReDim arr3(UBound(arrxs))
                '獲取所有學模組編號前5位
                For j = 1 To UBound(arr1)
                    arr1(j) = Left(Cells(1, j + 3).Value, 5)
                Next j
                '獲取所有學生的班級,利用arr3()儲存對應任課教師.
                For i = 1 To xsRS - 1
                    arr2(i) = Cells(i + 1, 3).Value
                Next i
                '按班級提取對應模組的任課教師姓名
                Sheets(Trim("教師名單" & Trim(Str(nj)))).Activate
                For RngK = 2 To Range("A65536").End(xlUp).Row
                    For j = 1 To UBound(arr1)
                        If Cells(RngK, 1).Value = arr1(j) Then
                            For RngB = 2 To Range("IV1").End(xlToLeft).Column
                                For i = 1 To xsRS - 1
                                    If arr2(i) = Cells(1, RngB) Then
                                        arr3(i) = Cells(RngK, RngB).Value
                                        Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                                        Cells(i + 1, j + 3).Value = arr3(i)
                                        Sheets(Trim("教師名單" & Trim(Str(nj)))).Activate
                                    End If
                                Next i
                            Next RngB
                        End If
                    Next j
                Next RngK
                '將任課教師姓名填充至對應模組學分檔案中.
                ReDim arr1(xsRS - 1)
                For j = 1 To totalR - 1
                    Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                    arr1() = Cells(2, j + 3).Resize(UBound(arr1), 1).Value
                    Workbooks.Open ThisWorkbook.Path & "\xx\高" & Trim(Str(nj)) & "\xx" & Trim(Cells(1, j + 3).Value) & ".xls"
                    Cells(2, 12).Resize(UBound(arr1), 1).Value = arr1
                    ActiveWorkbook.Close savechanges:=True
                Next j
                Sheets(Trim("學生名單" & Trim(Str(nj)) & wenli(wl))).Activate
                Range(Cells(1, 4), Cells(Range("A65536").End(xlUp).Row, Range("IV1").End(xlToLeft).Column + 1)).Clear
            Next wl
        End If
    Next nj
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "電腦舊點,速度慢點,最後還是完成了!^_^"
End Sub

需要提前收集的工作表如下:

image

除高1年,高2和高3需區別文理科,故建立工作表時特別處理.即需要老師名單1/老師名單2/老師3,領導及模組1/領域及模組2文/領域及模組2理/領域及模組3文/領域及模組3理,學生名單1/學生名單2文/學生名單2理/學生名單3文/學生名單3理,班主任名單1/班主任名單2/班主任名單3,這些工作表是必需的.

有了以上的資料及程式即可生成所有學生的學分檔案.

下面是關於其餘9個表格的處理,各分為兩塊內容:①按班生成資料,並預填寫資料,只保留需要班主任填寫的內容.②對收齊的資料進行批處理,自動將所有同類工作簿合併為一張大表,以便於資料處理.

以下是其中部分工作簿的處理方式,沒列出的部分請自行研究即可.

Option Explicit
Option Base 1
Sub BA01按班生成學生名單()
    Dim i As Integer, j As Integer, k As Integer, bjS As Integer
    Dim xxRs() As Integer, totalR As Integer, xxXx() As Variant
    bjS = 20 '共20個班,根據需要自行修改,但要求為連續班號
    ReDim xxRs(bjS)
    k = 0
    For i = 1 To bjS
        FileCopy ThisWorkbook.Path & "\樣表\xuesheng.xls", ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\xuesheng.xls"
        Sheets("學生名單").Activate
        totalR = Range("A65536").End(xlUp).Row
        xxRs(i) = Application.WorksheetFunction.CountIf(Range(Cells(2, 3), Cells(totalR, 3)), Trim(Str(i)))
        Debug.Print i & "班人數為" & xxRs(i)
        If xxRs(i) = 0 Then
            MsgBox "嚴重錯誤!!" & i & "班學生不存在,程式中止,請核實!!"
            Kill ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\*.*"
            RmDir ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
            Exit For
        End If
        '以下為預填充資料
        k = k + xxRs(i)
        xxXx() = Range(Cells(k - xxRs(i) + 2, 1), Cells(k + 1, 3))
        Workbooks.Open ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\xuesheng.xls"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 3)).NumberFormatLocal = "@"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 3)).Value = xxXx()
        ActiveWorkbook.Close savechanges:=True
        xxRs(i) = 0
        Erase xxXx()
    Next i
End Sub

Sub BA02合併xuesheng檔案()
    Dim i As Integer, myWorkbook As Workbook, totalR As Integer
    Dim arr(), bjS As Integer
    FileCopy ThisWorkbook.Path & "\樣表\xuesheng.xls", ThisWorkbook.Path & "\hb\xuesheng.xls"
    bjS = 20 '班級數為20,如果需要可自行修改
    For i = 1 To bjS
        Set myWorkbook = GetObject(ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\xuesheng.xls")
        With myWorkbook.Sheets(1)
             arr() = Range(.Cells(2, 1), .Cells(.Range("A65536").End(xlUp).Row, .Range("IV1").End(xlToLeft).Column))
        End With
        myWorkbook.Close savechanges:=False
        Workbooks.Open ThisWorkbook.Path & "\hb\xuesheng.xls"
        totalR = Range("A65536").End(xlUp).Row
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)).NumberFormatLocal = "@"
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)) = arr
        ActiveWorkbook.Close savechanges:=True
    Next i
End Sub

 

Option Explicit
Option Base 1
'B01程式主要解決
'①預填充學生資料,只空下評語,6個維度的評價,前2個維度一律為合格,後4個維度一律預填"良好",優秀學生由班主任掌握,不超5%
'②按班生成sy檔案,放至班級資料夾中
Sub B01預填充資料並按班生成檔案()
    Dim i As Integer, j As Integer, k As Integer, bjS As Integer
    Dim xxRs() As Integer, totalR As Integer, xxXx() As Variant
    '首先刪除指定資料夾下的所有子目錄,便於後續程式的執行
    '其次按指定班號建立對應子目錄
    '最後在子目錄均放置sy.xls檔案,以便於按班填充檔案
    bjS = 20 '共20個班,根據需要自行修改,但要求為連續班號
    ReDim xxRs(bjS)
    k = 0
    For i = 1 To bjS
        FileCopy ThisWorkbook.Path & "\樣表\sy.xls", ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\sy.xls"
        Sheets("學生名單").Activate
        totalR = Range("A65536").End(xlUp).Row
        xxRs(i) = Application.WorksheetFunction.CountIf(Range(Cells(2, 3), Cells(totalR, 3)), Trim(Str(i)))
        Debug.Print i & "班人數為" & xxRs(i)
        If xxRs(i) = 0 Then
            MsgBox "嚴重錯誤!!" & i & "班學生不存在,程式中止,請核實!!"
            Kill ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\*.*"
            RmDir ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
            Exit For
        End If
        '以下為預填充資料
        k = k + xxRs(i)
        xxXx() = Range(Cells(k - xxRs(i) + 2, 1), Cells(k + 1, 2))
        Workbooks.Open ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\sy.xls"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 12)).NumberFormatLocal = "@"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 1)).Value = Application.WorksheetFunction.Index(xxXx, 0, 1)
        Range(Cells(2, 2), Cells(UBound(xxXx) + 1, 2)).Value = "1" '此為學期,請自行修改!!
        Range(Cells(2, 3), Cells(UBound(xxXx) + 1, 3)).Value = Application.WorksheetFunction.Index(xxXx, 0, 2)
        Range(Cells(2, 4), Cells(UBound(xxXx) + 1, 5)).Value = "合格"
        Range(Cells(2, 6), Cells(UBound(xxXx) + 1, 9)).Value = "良好"
        Range(Cells(2, 11), Cells(UBound(xxXx) + 1, 11)).Value = Workbooks("源程式").Sheets("班主任名單").Cells(i + 1, 2).Value
        Range(Cells(2, 12), Cells(UBound(xxXx) + 1, 12)).Value = "20130130" '此為填寫時間,根據需要自行修改
        ActiveWorkbook.Close savechanges:=True
        xxRs(i) = 0
        Erase xxXx()
    Next i
End Sub
'B02程式主要解決
'①將各班返回資料中的sy檔案合併至大表中
'②對每位學生的評語字數按要求進行檢測,並對字數不合格的評語自動擷取或補充(但對字數為0的不予以處理,由班主任負責)
'③處理合格後,將大表檔案儲存為sy.xls,並將資料所在工作表更名為"Sheet1"
Sub B02合併基礎素養評價sy檔案()
    Dim i As Integer, myWorkbook As Workbook, totalR As Integer
    Dim arr(), bjS As Integer
    FileCopy ThisWorkbook.Path & "\樣表\sy.xls", ThisWorkbook.Path & "\hb\sy.xls"
    bjS = 20 '班級數為20,如果需要可自行修改
    For i = 1 To bjS
        Set myWorkbook = GetObject(ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\sy.xls")
        With myWorkbook.Sheets(1)
             arr() = Range(.Cells(2, 1), .Cells(.Range("A65536").End(xlUp).Row, .Range("IV1").End(xlToLeft).Column))
        End With
        myWorkbook.Close savechanges:=False
        Workbooks.Open ThisWorkbook.Path & "\hb\sy.xls"
        totalR = Range("A65536").End(xlUp).Row
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)).NumberFormatLocal = "@"
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)) = arr
        ActiveWorkbook.Close savechanges:=True
    Next i
End Sub

 

Option Explicit
Option Base 1

Sub C01預處理身體素質發展狀況st檔案()
    Dim i As Integer, j As Integer, k As Integer, bjS As Integer
    Dim xxRs() As Integer, totalR As Integer, xxXx() As Variant
    bjS = 20 '共20個班,根據需要自行修改,但要求為連續班號
    ReDim xxRs(bjS)
    k = 0
    For i = 1 To bjS
        FileCopy ThisWorkbook.Path & "\樣表\st.xls", ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\st.xls"
        Sheets("學生名單").Activate
        totalR = Range("A65536").End(xlUp).Row
        xxRs(i) = Application.WorksheetFunction.CountIf(Range(Cells(2, 3), Cells(totalR, 3)), Trim(Str(i)))
        Debug.Print i & "班人數為" & xxRs(i)
        If xxRs(i) = 0 Then
            MsgBox "嚴重錯誤!!" & i & "班學生不存在,程式中止,請核實!!"
            Kill ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\*.*"
            RmDir ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
            Exit For
        End If
        '以下為預填充資料
        k = k + xxRs(i)
        xxXx() = Range(Cells(k - xxRs(i) + 2, 1), Cells(k + 1, 2))
        Workbooks.Open ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\st.xls"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 2)).NumberFormatLocal = "@"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 2)).Value = xxXx()
        Range(Cells(2, 3), Cells(UBound(xxXx) + 1, 3)).Value = 1 '學年,如需要請自行修改
        ActiveWorkbook.Close savechanges:=True
        xxRs(i) = 0
        Erase xxXx()
    Next i
End Sub

Sub C02合併st檔案()
    Dim i As Integer, myWorkbook As Workbook, totalR As Integer
    Dim arr(), bjS As Integer
    FileCopy ThisWorkbook.Path & "\樣表\st.xls", ThisWorkbook.Path & "\hb\st.xls"
    bjS = 20 '班級數為20,如果需要可自行修改
    For i = 1 To bjS
        Set myWorkbook = GetObject(ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\st.xls")
        With myWorkbook.Sheets(1)
             arr() = Range(.Cells(2, 1), .Cells(.Range("A65536").End(xlUp).Row, .Range("IV1").End(xlToLeft).Column))
        End With
        myWorkbook.Close savechanges:=False
        Workbooks.Open ThisWorkbook.Path & "\hb\st.xls"
        totalR = Range("A65536").End(xlUp).Row
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)).NumberFormatLocal = "@"
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)) = arr
        ActiveWorkbook.Close savechanges:=True
    Next i

End Sub

 

Option Explicit
Option Base 1
Sub D01按班生成py檔案()
    Dim i As Integer, j As Integer, k As Integer, bjS As Integer
    Dim xxRs() As Integer, totalR As Integer, xxXx() As Variant
    bjS = 20 '共20個班,根據需要自行修改,但要求為連續班號
    ReDim xxRs(bjS)
    k = 0
    For i = 1 To bjS
        FileCopy ThisWorkbook.Path & "\樣表\py.xls", ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\py.xls"
        Sheets("學生名單").Activate
        totalR = Range("A65536").End(xlUp).Row
        xxRs(i) = Application.WorksheetFunction.CountIf(Range(Cells(2, 3), Cells(totalR, 3)), Trim(Str(i)))
        Debug.Print i & "班人數為" & xxRs(i)
        If xxRs(i) = 0 Then
            MsgBox "嚴重錯誤!!" & i & "班學生不存在,程式中止,請核實!!"
            Kill ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\*.*"
            RmDir ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
            Exit For
        End If
        '以下為預填充資料
        k = k + xxRs(i)
        xxXx() = Range(Cells(k - xxRs(i) + 2, 1), Cells(k + 1, 2))
        Workbooks.Open ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\py.xls"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 20)).NumberFormatLocal = "@"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 2)).Value = xxXx()
        Range(Cells(2, 4), Cells(UBound(xxXx) + 1, 4)).Value = Workbooks("源程式").Sheets("班主任名單").Cells(i + 1, 2).Value
        Range(Cells(2, 5), Cells(UBound(xxXx) + 1, 5)).Value = "20140725" '填寫時間,如需要請自行修改.
        ActiveWorkbook.Close savechanges:=True
        xxRs(i) = 0
        Erase xxXx()
    Next i

End Sub

Sub D02合併班主任綜合評語py檔案()
    Dim i As Integer, myWorkbook As Workbook, totalR As Integer
    Dim arr(), bjS As Integer
    FileCopy ThisWorkbook.Path & "\樣表\py.xls", ThisWorkbook.Path & "\hb\py.xls"
    bjS = 20 '班級數為20,如果需要可自行修改
    For i = 1 To bjS
        Set myWorkbook = GetObject(ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\py.xls")
        With myWorkbook.Sheets(1)
             arr() = Range(.Cells(2, 1), .Cells(.Range("A65536").End(xlUp).Row, .Range("IV1").End(xlToLeft).Column))
        End With
        myWorkbook.Close savechanges:=False
        Workbooks.Open ThisWorkbook.Path & "\hb\py.xls"
        totalR = Range("A65536").End(xlUp).Row
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)).NumberFormatLocal = "@"
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)) = arr
        ActiveWorkbook.Close savechanges:=True
    Next i

End Sub

 

Option Explicit
Option Base 1
Sub D01按班生成pj檔案()
    Dim i As Integer, j As Integer, k As Integer, bjS As Integer
    Dim xxRs() As Integer, totalR As Integer, xxXx() As Variant
    bjS = 20 '共20個班,根據需要自行修改,但要求為連續班號
    ReDim xxRs(bjS)
    k = 0
    For i = 1 To bjS
        FileCopy ThisWorkbook.Path & "\樣表\pj.xls", ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\pj.xls"
        Sheets("學生名單").Activate
        totalR = Range("A65536").End(xlUp).Row
        xxRs(i) = Application.WorksheetFunction.CountIf(Range(Cells(2, 3), Cells(totalR, 3)), Trim(Str(i)))
        Debug.Print i & "班人數為" & xxRs(i)
        If xxRs(i) = 0 Then
            MsgBox "嚴重錯誤!!" & i & "班學生不存在,程式中止,請核實!!"
            Kill ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\*.*"
            RmDir ThisWorkbook.Path & "\bzhr\" & Trim(Str(i))
            Exit For
        End If
        '以下為預填充資料
        k = k + xxRs(i)
        xxXx() = Range(Cells(k - xxRs(i) + 2, 1), Cells(k + 1, 2))
        Workbooks.Open ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\pj.xls"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 20)).NumberFormatLocal = "@"
        Range(Cells(2, 1), Cells(UBound(xxXx) + 1, 2)).Value = xxXx()
        Range(Cells(2, 4), Cells(UBound(xxXx) + 1, 4)).Value = "20140725" '填寫時間,如需要請自行修改.
        ActiveWorkbook.Close savechanges:=True
        xxRs(i) = 0
        Erase xxXx()
    Next i

End Sub

Sub E02合併學生高中綜合生活評價pj檔案()
    Dim i As Integer, myWorkbook As Workbook, totalR As Integer
    Dim arr(), bjS As Integer
    FileCopy ThisWorkbook.Path & "\樣表\pj.xls", ThisWorkbook.Path & "\hb\pj.xls"
    bjS = 20 '班級數為20,如果需要可自行修改
    For i = 1 To bjS
        Set myWorkbook = GetObject(ThisWorkbook.Path & "\bzhr\" & Trim(Str(i)) & "\pj.xls")
        With myWorkbook.Sheets(1)
             arr() = Range(.Cells(2, 1), .Cells(.Range("A65536").End(xlUp).Row, .Range("IV1").End(xlToLeft).Column))
        End With
        myWorkbook.Close savechanges:=False
        Workbooks.Open ThisWorkbook.Path & "\hb\pj.xls"
        totalR = Range("A65536").End(xlUp).Row
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)).NumberFormatLocal = "@"
        Range(Cells(totalR + 1, 1), Cells(totalR + UBound(arr), Range("IV1").End(xlToLeft).Column)) = arr
        ActiveWorkbook.Close savechanges:=True
    Next i

End Sub

後記:這是三天寫出來的小玩意,有人可能會說了,你怎麼不做個介面出來啊?介面當然可以,只是領導要求千變萬化,你再有本事,提前的開發要求你也不可能做到萬無一失,所以好軟體的標準是能否把活幹好,而不在於介面是否漂亮,再漂亮的東西,如果沒有內涵那也是沒價值啊.

對比以前寫的並於按班生成及合併檔案的程式碼,發現用陣列確實比單純的複製/貼上/篩選要快的得.

轉載於:https://www.cnblogs.com/xiehui/archive/2013/03/04/2942768.html

相關文章