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