|
楼主 |
发表于 2017-8-7 23:47
|
显示全部楼层
Sub Word以多个关键字拆分单个文档()
Dim i As Integer, n As Integer, doxt, Document, dox As Document
Dim Arr, Brr(), rng As Word.Range
Word.Application.ScreenUpdating = False
Arr = Array("黄埔区", "报名表", "承诺书", "交易文件")
ReDim Brr(UBound(Arr) + 1)
For i = 0 To UBound(Arr, 1)
With ThisDocument.Content.Find
.Text = "<" & Arr(i) & ">"
.MatchWildcards = True
Do While .Execute
If i Then
Brr(n) = .Parent.Previous(4, 1).End
Else
Brr(n) = .Parent.Start
End If
n = n + 1
Loop
If Not i = (n - 1) Then MsgBox Arr(i) & " 未查找到,退出": GoTo go_goo
End With
Next
Brr(n) = ThisDocument.Content.End
For i = 0 To UBound(Arr, 1)
Set doxt = ThisDocument.Range(Brr(i), Brr(i + 1))
doxt.Copy
Set dox = Documents.Add(ThisDocument.FullName)
With dox
.Content.Delete
.Content.Paste
Set rng = .Paragraphs(.Paragraphs.Count).Range
If Len(rng) = 1 Then rng.Delete
If Len(rng) = 0 Then rng.Delete
.SaveAs ThisDocument.Path & "" & Arr(i) & ".doc"
.Close True
End With
Next i
MsgBox "拆分成了 " & n & " 文档"
go_goo:
Word.Application.ScreenUpdating = True
Set Arr = Nothing: Set rng = Nothing
Set doxt = Nothing: Set dox = Nothing
End Sub |
|