20170706wdVBA正则表达式提取题目

Public Sub GetContents()
    Dim Reg As Object
    Dim Matches As Object
    Dim OneMatch As Object
    Dim Index As Long
    Dim TimeStart As Variant
    TimeStart = VBA.Timer
    Set Reg = CreateObject("Vbscript.RegExp")
    With Reg
        .Pattern = "^\s*?((?:[^\r]*?\d+题[^\r]?\s*?[^\r]*?\s*?)?\d*[\.，、．](?:[^\r\n]*?\r?[\r\n]+?){1,4}?)\s*?" & _
                   "(A[\.，、．].*?)\s+?" & _
                   "(B[\.，、 ．].*?)\s+?" & _
                   "(C[\.，、．].*?)\s+?" & _
                   "(D[\.，、．].*?)\s*?" & "\r?[\r\n]+"
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
    End With

    Dim FilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .InitialFileName = ActiveDocument.Path
        .Title = "请选择单个Excel工作簿"
        .Filters.Clear
        .Filters.Add "Excel工作簿", "*.xls*"
        If .Show = -1 Then
            FilePath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件夹，本次汇总中断！"
            Exit Sub
        End If
    End With

    Dim xlApp As Object
    Dim wb As Object
    Dim sht As Object
    Dim StartRow As Long
    Dim StartIndex As Long

    Set xlApp = CreateObject("Excel.Application")
    Set wb = xlApp.workbooks.Open(FilePath)
    Set sht = wb.worksheets.Add(After:=wb.worksheets(wb.worksheets.Count))
    sht.Name = "提取记录" & wb.worksheets.Count - 1
    sht.Range("A1:H1").Value = Array("储存序号", "引言题干", "A选项", "B选项", "C选项", "D选项", "正确答案", "配图名称")

    With sht
        StartRow = .Range("A65536").End(3).Row
        StartIndex = StartRow - 1

        Set Matches = Reg.Execute(ActiveDocument.Content.Text)
        Index = 0
        For Each OneMatch In Matches
            Index = Index + 1
            ''Debug.Print "Question Index  " & N & "   :   " '; OneMatch
            For i = 0 To OneMatch.submatches.Count - 1
                .Cells(StartRow + Index, 1).Value = StartIndex + Index
                .Cells(StartRow + Index, 2).Value = OneMatch.submatches(0)
                .Cells(StartRow + Index, 3).Value = OneMatch.submatches(1)
                .Cells(StartRow + Index, 4).Value = OneMatch.submatches(2)
                .Cells(StartRow + Index, 5).Value = OneMatch.submatches(3)
                .Cells(StartRow + Index, 6).Value = OneMatch.submatches(4)
                'If i <> 0 Then
                'Debug.Print ">>>>Option Index"; i; "  :   "; OneMatch.submatches(i)
                'Else
                '  Debug.Print ">>>>Question Index  0 "; "  :   "; OneMatch.submatches(i)
                ' End If
            Next i
            ' If N = 17 Then Exit For
        Next

        With .usedrange
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With

        If ShowPicName Then xlApp.WorksheetFunction.Transpose (PicName)

        .usedrange.Columns.AutoFit
    End With

    wb.Close True
    xlApp.Quit
    Set sht = Nothing
    Set wb = Nothing
    Set xlApp = Nothing

    Debug.Print VBA.Timer - TimeStart; "秒"
    Set Reg = Nothing
End Sub