上一次学生评语的导入问题，因为当时不会从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