关于发展报告的相关文件生成的源程序
按照要求,发展报告中的数据文件共有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
后记:这是三天写出来的小玩意,有人可能会说了,你怎么不做个界面出来啊?界面当然可以,只是领导要求千变万化,你再有本事,提前的开发要求你也不可能做到万无一失,所以好软件的标准是能否把活干好,而不在于界面是否漂亮,再漂亮的东西,如果没有内涵那也是没价值啊.
对比以前写的并于按班生成及合并文件的代码,发现用数组确实比单纯的复制/粘贴/筛选要快的得.
