请问在word用VBA如何批量将不同文件中的部分内容顺序复制到一个word文件中？

' 1 新建一个文件
' 2 (用Do..Loop)依次打开D:\目录下Z开头的.DOCx文件
' 3 复制其中满足条件的部份到剪切板，并关闭这个文件，回到新建的空白文件
' 4 粘贴
' 5 重复2－4
’6 结束，保留复制粘贴的内容为当前文件

Sub DoThis()
Dim myPath, myFile
myPath = "d:\"

Documents.Add DocumentType:=wdNewBlankDocument

myFile = Dir(myPath & "Z*.doc", vbNormal)

Do While myFile <> ""
Documents.Open myPath & myFile

DoCopyRange

ActiveWindow.Close

Selection.Paste

Selection.TypeParagraph
myFile = Dir

Loop
End Sub

Sub DoCopyRange()
Selection.Find.ClearFormatting
With Selection.Find
.Text = "A"
.Wrap = wdFindContinue
End With
Selection.Find.Execute
a = Selection.End

Selection.Find.ClearFormatting
With Selection.Find
.Text = "B"
.Wrap = wdFindContinue
End With
Selection.Find.Execute
b = Selection.Start

Selection.Start = a + 1
Selection.End = b

Selection.Copy

End Sub

Sub DrawObjAndSave()
DocX = False
SaveDocName = "提取并保存" '保存的新文档的名字可以自己更改
SaveDoc = "C:\" & SaveDocName & ".doc" '保存的新文档的名字可以自己更改
Documents.Add DocumentType:=wdNewBlankDocument
Documents.Save SaveDoc
Set MyDocSave = Documents.Open(SaveDoc)
Path = "C:\test\" '目标文件所在的目录，可自行修改
MyDoc = Path & Dir(Path & "*.doc") '如果还要包括docx类型的话，则为 MyDoc = Path & Dir(Path & "*.docx")
DoAgain:
Do While MyDoc <> Path
Set MyDocOpen = Documents.Open(MyDoc)
Selection.Find.ClearFormatting
Do
With Selection.Find
.Text = "*^13" '*可以替换成特定的需要查找的目标内容的通配符表达式
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute
Selection.Copy
Windows(SaveDocName).Activate
Selection.Paste
MyDocSave.Save
Loop While Selection.Find.Found
MyDocOpen.Saved = True
MyDocOpen.Close
If Not DocX Then
MyDoc = Path & Dir(Path & "*.docx")
DocX = True
GoTo DoAgain
End If
MyDocSave.Close
MsgBox "处理完毕！", vbInformation + vbOKOnly, "消息"
Applicatiction.quit
End Sub

都找到这段代码了，把Text部分换成你要搜索的就可以了。
例如段落的开头都是以“很久以前”开始，结束都是以“过上幸福的生活。”那么：
Sub DoThis()
Selection.Find.ClearFormatting
With Selection.Find
.Text = "很久以前"
.Wrap = wdFindContinue
End With
Selection.Find.Execute
a = Selection.End

Selection.Find.ClearFormatting
With Selection.Find
.Text = "过上幸福的生活。"
.Wrap = wdFindContinue
End With
Selection.Find.Execute
b = Selection.Start

Selection.Start = a + 1
Selection.End = b

Selection.Copy

End Sub