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