按照要求,發展報告中的資料檔案共有9個:
程式實現的目標是對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
建立後的截圖如下:
考慮到一次集中處理的是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
需要提前收集的工作表如下:
除高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
後記:這是三天寫出來的小玩意,有人可能會說了,你怎麼不做個介面出來啊?介面當然可以,只是領導要求千變萬化,你再有本事,提前的開發要求你也不可能做到萬無一失,所以好軟體的標準是能否把活幹好,而不在於介面是否漂亮,再漂亮的東西,如果沒有內涵那也是沒價值啊.
對比以前寫的並於按班生成及合併檔案的程式碼,發現用陣列確實比單純的複製/貼上/篩選要快的得.