20170724wdVBA正则表达式提取答案到Excel

Public Sub RegExtractData()
    Dim StartTime, UsedTime
    StartTime = VBA.Timer

    Dim FilePath$
    Dim FileName$
    Dim doc As Document
    Dim Arr() As String
    Dim ExamNo As String
    Dim Index As Long
    Dim Count As Long

    Dim xlApp As Object    'Excel.Application
    Dim wb As Object    'Excel.Workbook
    Dim sht As Object    'Excel.Worksheet
    Dim Reg As Object, Mh As Object, OneMh As Object
    Set Reg = CreateObject("Vbscript.Regexp")
    With Reg
        .MultiLine = True
        .Global = True
        .Ignorecase = False
    End With

    Application.ScreenUpdating = False
    Application.DisplayAlerts = wdAlertsNone

    FilePath = ThisDocument.Path & "\试卷\"
    FileName = Dir(FilePath & "*.doc*")

    Count = 0
    ReDim Arr(1 To 3, 1 To 1)

    Do While FileName <> ""
        Debug.Print FilePath & FileName
        Set doc = Application.Documents.Open(FilePath & FileName)
        Index = 0
        Content = doc.Content.Text

        '试卷编号：0199
        Reg.Pattern = "(?:试卷编号：)(\S+?)(?:[\s]+?)"
        Set Mh = Reg.Execute(Content)
        ExamNo = "'" & Mh.Item(0).submatches(0)
        Debug.Print ExamNo

        '答案：A|B|C
        Reg.Pattern = "(?:答案：)(\S+?)(?:[\s]+?)"
        Set Mh = Reg.Execute(Content)
        For Each OneMh In Mh
            Index = Index + 1
            Count = Count + 1
            ReDim Preserve Arr(1 To 3, 1 To Count)
            Arr(1, Count) = ExamNo
            Arr(2, Count) = Index
            Arr(3, Count) = OneMh.submatches(0)
        Next OneMh

        doc.Close
        FileName = Dir
    Loop

    Set Reg = Nothing

    Application.ScreenUpdating = True
    Application.DisplayAlerts = wdAlertsAll

    Set xlApp = CreateObject("Excel.Application")    'Excel.Application
    With xlApp
        Set wb = xlApp.Workbooks.Add   'Open(ThisDocument.Path & "\" & "答案模板.xls")
        With wb
            Set sht = .Worksheets("Sheet1")
            With sht
                .Range("A1:C1").Value = Array("试卷编号", "题号", "答案")
                .Range("A2").Resize(Count, 3).Value = xlApp.WorksheetFunction.Transpose(Arr)
            End With
            'xlApp.WorksheetFunction.Transpose (Arr)
            .SaveAs ThisDocument.Path & "\" & Format(Now(), "yyyymmdd-hhmm") & "-答案.xls"
            .Close True
        End With
        .Quit
    End With

    Set xlApp = Nothing
    Set wb = Nothing
    Set sht = Nothing
    UsedTime = VBA.Timer - StartTime
    MsgBox "提取完成！用时" & Format(UsedTime, "0.00 秒。")

End Sub