如何实现学生评语的导入
上一次学生评语的导入问题，因为当时不会从word中导入，所以只能要求学生用Excel填写，然后导入到大表当中去的，在实际操作中发现学生对Excel并不熟悉，导致了出现了大量的错误，学生比较熟悉的还是Word，所以现在这个程序就是来解决如何从Word中读取学生评语，然后导入到Excel中指定单元格中。由于只是要求学生把3个学期的评语分成三段来书就可以，这样应该可以更加减少学生出错的机率。
原始文件的存放格式如下图所示：
保证文件格式以及存放位置如上图所示。
一、将word版评语转化为Excel版评语：
Sub 将word评语转换成Excel评语()
Dim sr As FileSearch '定义一个文件搜索对象
Dim i As Integer, j As Integer, k As Integer
Dim myFile As String, cp As String
Dim docApp As Word.Application '定义前要先定义一个word对象的引用。
Dim docRange As Word.Range
Set sr = Application.FileSearch
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To 1 '按班级
sr.LookIn = "E:导入评语word学生评语汇总" & Trim(Str(i)) & "班" '注意路径，换成你实际的路径
sr.Filename = "*.doc" '搜索所有文件
sr.Execute '执行搜索
Cells.Delete '表格清空
For k = 1 To sr.FoundFiles.Count
myFile = sr.FoundFiles(k) '指定Word文档，要保证将电子表格与word文档放在同一文件夹下。
Set docApp = New Word.Application
docApp.Documents.Open myFile
Workbooks.Add
For j = 1 To 3 '为了防止学生多敲回车，可以将此处改为3（代表3个学期）
With docApp.ActiveDocument
'If .Paragraphs.Count >= 4 Then
Set docRange = .Paragraphs(j).Range 'Paragraphs是段的意思
'cp = docRange
ActiveWorkbook.ActiveSheet.Range(Cells(j, 1), Cells(j, 1)).Value = docRange
'End If
End With
Next j
'Range("a1") = cp
docApp.Quit savechanges:=False
Set docRange = Nothing
Set docApp = Nothing
ActiveWorkbook.SaveAs Filename:=Left(sr.FoundFiles(k), Len(sr.FoundFiles(k)) - 4) & ".xls"
ActiveWorkbook.Close savechanges:=True
Next k
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
二、清除100字评语
Sub 清除100字评语2()
Dim xueqi, bj, i As Integer
For xueqi = 1 To 3
For bj = 1 To 23
Workbooks.Open "E:导入评语word第" & Format(Str(xueqi)) & "学期发展报告上传数据" & Format(Str(bj)) & "班" & "sy.xls"
totalR = Range("A65536").End(xlUp).Row
Range(Cells(2, 10), Cells(totalR, 10)).clear
Workbooks("sy.xls").Close savechanges:=True
Next bj
Next xueqi
End Sub
本来想做个对象，可以实现不打开sy.xls就可以清除，但这是不可能的，利用getobject只可引用，但不能写入，即只可以读，不可以写。
但可以通过ADO的方法来实现，一会再研究。
三、将所有学生的Excel版评语导入到“班级”sy.xls中：
Sub 将学生评语提取到班级素养表中进行汇总()
Application.DisplayAlerts = False
Dim totalR, i, xueqi, bj As Integer
Dim mypath As String
Dim py(), xh() As String
Dim wb As Object
For xueqi = 1 To 3
For bj = 1 To 23
Workbooks.Open "E:导入评语word第" & Format(Str(xueqi)) & "学期发展报告上传数据" & Format(Str(bj)) & "班" & "sy.xls"
totalR = Range("A1").CurrentRegion.Rows.Count
mypath = ActiveWorkbook.Path
ReDim py(totalR - 1), xh(totalR - 1)
For i = 2 To totalR
xh(i - 1) = Cells(i, 1).Value
Next i
For i = 2 To totalR
Set wb = GetObject("E:导入评语word学生评语汇总" & Format(Str(bj)) & "班" & xh(i - 1) & ".xls")
On Error Resume Next
py(i - 1) = wb.Sheets(1).Cells(xueqi, 1).Value
wb.Close False
Set wb = Nothing
Debug.Print py(i - 1)
Next i
'Workbooks("sy.xls").Activate
For i = 2 To totalR
Cells(i, 10).Value = py(i - 1)
Next i
ActiveWorkbook.Close savechanges:=True
Next bj
On Error GoTo 0
Next xueqi
End Sub
试验程序：
Sub 读取Word文档到Excel中()
Dim myFile As String, i As Integer, cp As String
Dim docApp As Word.Application '定义前要先定义一个word对象的引用。
Dim docRange As Word.Range
myFile = ThisWorkbook.Path & "3.doc" '指定Word文档，要保证将电子表格与word文档放在同一文件夹下。
Set docApp = New Word.Application
docApp.Documents.Open myFile
For i = 1 To docApp.ActiveDocument.Paragraphs.Count '为了防止学生多敲回车，可以将此处改为3（代表3个学期）
With docApp.ActiveDocument
'If .Paragraphs.Count >= 4 Then
Set docRange = .Paragraphs(i).Range 'Paragraphs是段的意思
'cp = docRange
Range(Cells(i, 1), Cells(i, 1)).Value = docRange
'End If
End With
Next i
'Range("a1") = cp
docApp.Quit
Set docRange = Nothing
Set docApp = Nothing
'Set ws = Nothing
End Sub
再解决一下如何读取顺序文件，源程序如下：
Sub ReadMe()
Dim rLine As String
Dim i As Integer ' 行号
i = 1
Open "C:Autoexec.bat" For Input As #1
'在循环里直到过程结束
Do While Not EOF(1)
Line Input #1, rLine
MsgBox "行" & i & " 在Autoexec.bat中读取: " _
& Chr(13) & Chr(13) & rLine
i = i + 1
Loop
MsgBox i & "行被读取."
Close #1
End Sub
今天你菊子曰了么？
