|
|
Option Explicit
Sub TEST()
Dim strFileName$, strPath$, ar(), br(), strJoin$, i&, j&, r&, n&, regEx As Object, Par As Paragraph
strPath = ThisDocument.Path & "\"
strFileName = strPath & "药师审方技能培训荟萃--第四章--答案解析.docx"
If Dir(strFileName) = "" Then MsgBox "指定答案解析文件不存在，请检查！", vbExclamation: Exit Sub
Application.ScreenUpdating = False
Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = "^[0-9]+\.[A-Z]+"
With Documents.Open(strFileName)
For Each Par In .Paragraphs
If regEx.TEST(Par.Range.Text) Then
n = Len(regEx.Execute(Par.Range.Text)(0))
r = r + 1
ReDim Preserve ar(1 To r)
Set ar(r) = .Range(Par.Range.Start, Par.Range.Start + n)
End If
Next
For j = 1 To UBound(ar)
If j = UBound(ar) Then
ar(j).SetRange ar(j).End, .Range.End
Else
ar(j).SetRange ar(j).End, ar(j + 1).Start
End If
ar(j) = Replace(ar(j).Text, vbCr, "")
Next j
.Close False
End With
r = 0
With Documents.Add
ThisDocument.Content.Copy
.Range(0).Paste
regEx.Pattern = "^[0-9]+\."
For Each Par In .Paragraphs
If regEx.TEST(Par.Range.Text) Then
r = r + 1
ReDim Preserve br(1 To r)
Set br(r) = .Range(Par.Range.Start, Par.Range.Start)
End If
Next
For i = 1 To UBound(br)
If i = UBound(br) Then
br(i).SetRange .Range.End, .Range.End
Else
br(i).SetRange br(i + 1).Start, br(i + 1).End
End If
Next i
If UBound(ar) < r Then r = UBound(ar)
For j = 1 To r
If j = r Then strJoin = ar(j) Else strJoin = ar(j) & vbCr
With br(j)
.InsertAfter strJoin
.Font.ColorIndex = wdRed
End With
Next j
End With
Application.ScreenUpdating = True
Beep
End Sub
|
评分
-
4
查看全部评分
-
|
楼主: zq8908ang
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-4-23 20:32
楼主
