20181014xlVBA获取小题零分名单

Sub GetZeroName()
    Dim Dic As Object
    Const SUBJECT = "科目名称"
    Dim Key As String
    Dim OneKey
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim FolderPath As String
    Dim FileName As String
    Dim FilePath As String
    Dim wdApp As Object
    Dim wdDoc As Object

    Const StartCol = "G"
    Const EndCol = "X"
    Set Dic = CreateObject("Scripting.Dictionary")
    Set Wb = Application.ThisWorkbook
    FolderPath = Wb.Path & "\"
    Set Sht = Wb.Worksheets(1)
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If wdApp Is Nothing Then
        Set wdApp = CreateObject("Word.Application")
    End If
    On Error GoTo 0

    With Sht
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        For i = 2 To EndRow
            Key = .Cells(i, 3).Text
            Dic(Key) = ""
        Next

        For Each OneKey In Dic.Keys

            FileName = OneKey & "班" & SUBJECT & "小题零分名单.docx"
            On Error Resume Next
            wdApp.documents(FileName).Close
            On Error GoTo 0

            FilePath = FolderPath & FileName
            On Error Resume Next
            Kill FilePath
            On Error GoTo 0

            report = OneKey & "班" & SUBJECT & "小题零分名单" & vbCrLf
            For j = .Cells(1, StartCol).Column To .Cells(1, EndCol).Column

                'Key = OneKey & ";" & .Cells(1, j).Text
                report = report & vbCrLf & "【" & .Cells(1, j).Text & "】--------------------------------------------------------------------------------------------------------------" & vbCrLf & "    "
                For i = 2 To EndRow
                    If .Cells(i, 3).Text = OneKey Then
                        If .Cells(i, j).Value = 0 Then
                            report = report & .Cells(i, 2).Value & "；"
                        End If
                    End If
                Next i
            Next j
            'Debug.Print "__________________________________________________________________________________"
            'Debug.Print report

            Set wdDoc = wdApp.documents.Add
            wdDoc.SaveAs FilePath
            wdApp.Selection.typetext report
            wdDoc.Save
            wdDoc.Close

        Next OneKey

    End With

    wdApp.Quit
    Set Wb = Nothing
    Set Sht = Nothing
    Set wdApp = Nothing
    Set wdDoc = Nothing
End Sub