word题库中提取题号和答案-Excel VBA程序开发-ExcelHome技术论坛

蓝色仰望 Lv.2

2022-8-31 15:49 关注

求助各位大神，word题库中提取题号和答案，然后将题库中的答案和下边的依据删除。原题库内容很多，有的题是有依据，有的没有。劳烦大神帮助，谢谢！题库在附件中，谢谢！

竞赛题库.zip 2022-8-31 15:49 上传

14.47 KB, 下载次数: 35

赏

2936阅读

x-xx-xx Lv.4 2楼

2022-8-31 18:14

https://club.excelhome.net/forum.php?mod=viewthread&tid=1629699&extra=&mobile=2

chxw68 Lv.7 3楼

2022-8-31 20:17

Sub test()
' Dim wordapp As Object
' Dim mydoc As Object
' Set wordapp = CreateObject("word.application")
' Set mydoc = CreateObject("word.document")
Dim wordapp As New Word.Application
Dim mydoc As New Word.Document
Dim r%, i%
Dim myapth$, myname$
Dim reg1 As New regexp
Dim reg2 As New regexp
Dim brr()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With reg1
.Global = False
' .Pattern = "[$（](\s*[A-D])\s*[$）]"
.Pattern = "^(\d+)\.(.+)$"
End With
With reg2
.Global = True
.Pattern = "([A-D])\.(.*?)(?=[A-D]|$)"
End With
Filename = Application.GetOpenFilename(filefilter:="Excel 文件 (*.doc;*.docx),*.doc;*.docx", MultiSelect:=False)
If VarType(Filename) = vbBoolean Then
MsgBox "没有选择源文件！"
wordapp.Quit
Exit Sub
End If
Set mydoc = wordapp.Documents.Open(Filename)
' Set mydoc = GetObject(Filename)
wordapp.Visible = True
With mydoc
ReDim brr(1 To .Paragraphs.Count, 1 To 6)
m = 0
For i = 1 To .Paragraphs.Count
ss = .Paragraphs(i).Range.listformat.liststring & .Paragraphs(i).Range.Text
ss = Left(ss, Len(ss) - 1)
If Len(ss) <> 0 Then
If reg1.test(ss) Then
Set mh1 = reg1.Execute(ss)
m = m + 1
brr(m, 1) = mh1(0).SubMatches(0)
brr(m, 2) = mh1(0).SubMatches(1)
' brr(m, 1) = reg1.Replace(ss, "(" & Space(5) & ")")
' brr(m, 6) = mh1(0).SubMatches(0)
Else
Set mh2 = reg2.Execute(ss)
If mh2.Count > 0 Then
For j = 0 To mh2.Count - 1
n = Asc(mh2(j).SubMatches(0)) - 62
brr(m, n) = Trim(mh2(j).SubMatches(1))
Next
End If
End If
End If
Next
.Close
End With
wordapp.Quit
With Worksheets("sheet1")
.UsedRange.Offset(1, 0).ClearContents
.Cells.NumberFormatLocal = "@"
If m > 0 Then
With .Range("a2").Resize(m, UBound(brr, 2))
.Value = brr
.Borders.LineStyle = xlContinuous
End With
End If
End With
Application.ScreenUpdating = True
MsgBox "题目导入完毕！"
End Sub