![](/img/trans.png)
[英]from Xcel Vba select a range of text from one Word document and copy into another Word document
[英]How do I copy the contents of one word document to the end of another using vba?
我希望能够复制一个文档的内容并将该选择附加到另一个文档的末尾。
它的作用 ...... (这只是背景信息,所以你理解我为什么要这样做):
我正在尝试动态生成一个文档,该文档引用了有关产品所涉及的不同部件和材料的各种信息。
文档本身具有一致的格式,我将其分解为两个文档。 第一个包含需要手动输入的一堆数据,并且是我想要附加所有其他内容的地方。 第二个包含大约十几个自定义字段,这些字段是从VBA中的Excel电子表格更新的。 对于单个部分和单个文档,这可以按我的意愿工作(我的基本情况)。 但是我的问题是当项目有多个部分时。
对于多个部分,我必须将信息存储在一个数组中,该数组随着每个附加部分的添加而动态变化。 当有人添加了所有必要的部件后,他们可以选择一个名为“创建报价”的按钮。
创建报价运行一个过程,该过程创建/打开上述两个模板文档的单独副本(保存在我的计算机上)。 然后,它遍历部件数组并更新第二个文档中的所有自定义字段(没有问题)。 现在我只需要将第二个文档的内容添加到第一个文档的末尾,这是我的问题。
理想情况下,我的过程将继续遍历数组中的每个部分 - 更新自定义字段,复制然后粘贴更新的文本,重复...直到每个部分都包含在新生成的引用中。
我尝试了什么 - 这个代码可以在我的生成报价程序中找到
我已经尝试了许多有类似问题的人提供的示例和建议,但我不知道是不是因为我是在excel doc上运行,但他们的许多解决方案对我没有用。
这是我最近的尝试,发生在for循环的每次迭代之后
wrdDoc2.Fields.Update 'Update all the fields in the format document
wrdDoc2.Activate
Selection.WholeStory ' I want to select the entire document
Selection.Copy ' Copy the doc
wrdDoc1.Activate ' Set focus to the target document
Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
Selection.PasteAndFormat wdPasteDefault
引用程序 - 我只包括一些我正在更新的字段,因为没有必要全部显示它们
Private Sub quote_button_Click()
On Error GoTo RunError
Dim wrdApp1, wrdApp2 As Word.Application
Dim wrdDoc1, wrdDoc2 As Word.Document
Set wrdApp1 = CreateObject("Word.Application")
Set wrdApp2 = CreateObject("Word.Application")
wrdApp1.Visible = True
wrdApp2.Visible = True
Set wrdDoc1 = wrdApp1.Documents.Add(Template:="C:\MWES\AQT_v1.1(start).docm", NewTemplate:=False, DocumentType:=0)
Set wrdDoc2 = wrdApp2.Documents.Add(Template:="C:\MWES\AQT_v2.1(format).docm", NewTemplate:=False, DocumentType:=0)
Dim propName As String
For i = LBound(part_array, 1) To UBound(part_array, 1)
For Each prop In wrdDoc2.CustomDocumentProperties
propName = prop.name
' Looks for and sets the property name to custom values of select properties
With wrdDoc2.CustomDocumentProperties(propName)
Select Case propName
Case "EST_Quantity"
.value = part_array(i, 0) ' "QTY" ' Sheet1.Cells(1, 3) 'NA
Case "EST_Metal_Number"
.value = part_array(i, 1) ' "METAL_#" ' Sheet1.Cells(2, 3) 'NA"
Case "EST_Metal_Name"
.value = part_array(i, 2) ' "METAL_N" ' Sheet1.Cells(5, 2)
End Select
End With
Next prop ' Iterates until all the custom properties are set
wrdDoc2.Fields.Update 'Update all the fields in the format document
wrdDoc2.Activate
Selection.WholeStory ' I want to select the entire document
Selection.Copy ' Copy the doc
wrdDoc1.Activate ' Set focus to the target document
Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
Selection.PasteAndFormat wdPasteDefault
Next i ' update the document for the next part
RunError: ' Reportd any errors that might occur in the system
If Err.Number = 0 Then
Debug.Print "IGNORE ERROR 0!"
Else
Dim strError As String
strError = "ERROR: " & Err.Number & vbCrLf & Err.Description & vbCrLf & Erl
MsgBox strError
Debug.Print strError & " LINE: " & Erl
End If
End Sub
我道歉这是如此漫长的啰嗦。 如果有任何令人困惑的事情或者您可能需要澄清,请告诉我。 我想我包括了一切。
我认为你很接近,所以这里有几条评论和一个例子。
首先,您将打开两个单独的MS Word应用程序对象。 你只需要一个。 实际上,复制/粘贴可能会失败,因为您尝试从一个Word应用程序复制到另一个Word应用程序中打开的文档。 (相信我,我见过这样奇怪的事情。)我的下面的例子显示了如何通过只打开一个应用程序实例来做到这一点。
Dim mswApp As Word.Application
Set mswApp = AttachToMSWordApplication() 'more on this function below...
Dim doc1 As Word.Document
Dim doc2 As Word.Document
Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")
虽然我不经常为Word编写代码,但我发现有很多不同的方法可以使用不同的对象或属性来获取相同的内容。 这始终是混乱的根源。
基于这个过去对我有用的答案 ,然后我设置源和目标范围来执行“复制”:
Dim destination As Word.Range
Dim source As Word.Range
Set source = doc1.Content
Set destination = doc2.Content
destination.Collapse Direction:=Word.wdCollapseEnd
destination.FormattedText = source
以下是整个模块供参考:
Option Explicit
Sub AddDocs()
Dim wordWasRunning As Boolean
wordWasRunning = IsMSWordRunning()
Dim mswApp As Word.Application
Set mswApp = AttachToMSWordApplication()
Dim doc1 As Word.Document
Dim doc2 As Word.Document
Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")
Dim destination As Word.Range
Dim source As Word.Range
Set source = doc1.Content
Set destination = doc2.Content
destination.Collapse Direction:=Word.wdCollapseEnd
destination.FormattedText = source
doc2.Close SaveChanges:=True
doc1.Close
If Not wordWasRunning Then
mswApp.Quit
End If
End Sub
这是我在样本中使用的几个函数的承诺说明。 我已经构建了一组库函数,其中一些函数可以帮助我访问其他Office应用程序。 我将这些模块保存为.bas
文件(通过使用VBA编辑器中的导出功能)并根据需要导入它们。 因此,如果您想使用它,只需使用纯文本编辑器(不在VBA编辑器中)保存下面的代码,然后将该文件导入到项目中。
建议的文件名是Lib_MSWordSupport.bas
:
Attribute VB_Name = "Lib_MSWordSupport"
Attribute VB_Description = "Variety of support functions operating on MS Word"
Option Explicit
Public Function IsMSWordRunning() As Boolean
Attribute IsMSWordRunning.VB_Description = "quick check to see if an instance of MS Word is running"
'--- quick check to see if an instance of MS Word is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- not running
IsMSWordRunning = False
Else
'--- running
IsMSWordRunning = True
End If
End Function
Public Function AttachToMSWordApplication() As Word.Application
Attribute AttachToMSWordApplication.VB_Description = "finds an existing and running instance of MS Word, or starts the application if one is not already running"
'--- finds an existing and running instance of MS Word, or starts
' the application if one is not already running
Dim msApp As Word.Application
On Error Resume Next
Set msApp = GetObject(, "Word.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Word.Application")
End If
Set AttachToMSWordApplication = msApp
End Function
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.