Question

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

比如在一个文件夹有若干个文件，现在想把其中每个文件中满足条件的段落复制到一个新建的文件，VBA代码该如何写？或者在http://zhidao.baidu.com/question/403211860的基础上怎么改写？谢谢

Answer 1

' 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

Answer 2

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

追问

谢谢回答，但调试出错。

追答

这个才是标准的VBA.但不知道你调试时为啥会出错？在我的版本中是正确的。
Selection.Start = a + 1
Selection.End = b
这是不标准的。

追问

再次感谢，你回答的很详细。我也把这段代码复制下来慢慢研究。现在提示“Do没有Loop”

Answer 3

都找到这段代码了，把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

追问

链接里的代码我能看懂。我想知道怎么把各文件中查到的段落复制到另一个word文档中去。

Answer 4

你说的太复杂了，不容易实现