' 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
' 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