I haven’t used VB for years, so please forgive me if this turns out to be obvious. I’m trying to write a word vba macro for use in a template which will display a userform and then import the contents of fileA.docx, fileB.docx, or fileC.docx depending on the userform. (After that I’m going to use bookmarks to fill in some form data, I don’t know if that’s relevant). Files A, B, and C will contain text with some basic formatting such as lists, but nothing fancy.
The solutions I’ve seen online can copy the contents of file to a new file, but ideally I would like to import the entirety of one of those files into the new, currently unnamed file that I’m getting from the template. I think where I’m running into problems is with switching the selection to one of those files, and then back to the new unnamed document, though I could use a hand to make sure I’m copying correctly as well.
Update: I was making things too hard, though the answers here got me pointed in the right direction (thanks!). In the end I just did
ThisDocument.Activate
Selection.InsertFile("fileA")
which gives me the raw dump of everything that I wanted.
| Код |
|---|
Sub Zapusk_Word_iz_Excel_02()
Dim objWrdApp As Object
Dim objWrdDoc As Object
Dim text As Object
On Error Resume Next
Set objWrdApp = GetObject(, "Word.Application")
If objWrdApp Is Nothing Then
Set objWrdApp = CreateObject("Word.Application")
Set objWrdDoc = objWrdApp.Documents.Open("D:WorkMKTANL.RTF")
objWrdApp.Visible = True
End If
Set objWrdDoc = objWrdApp.Documents.Open("D:WorkMKTANL.RTF")
Set text = objWrdDoc.Content
Set objWrdDoc = Nothing
Set objWrdApp = Nothing
End Sub
|
Как выгрузить эту бяку на лист в ексель не пойму
Скопировать нужно все из Word и в ставить на лист, но не в одну ячейку.
Изменено: Сергей Беляев — 02.02.2017 13:47:55
This tutorial explains how you can copy content from one word document and paste it to another word document with VBA. This is one of the most common ask from stakeholder when you need to create a new MS word document daily or weekly which is a subset of the master document. If you do it manually, it’s a tedious task and chances of having error would be high. In the automated world we aim to automate our repetitive tasks as much as possible. As a request it looks easy but it’s a bit complex as you need to handle MS word from Excel and need to give instructions to system via VBA about the changes and interactivity you want to implement.
Table of Contents
Copy all headings to another document
The program below copies each text which is formatted in Heading 1 style and paste to a new word document. You need to make changes in the lines of code highlighted in red.
Sub CopyfromWord()
' Objects
Dim wrdApp, objWord As Object
Dim wrdDoc, newwrdDoc As Object
Dim myPath As String, myPath1 As String
Dim numberStart As Long
Dim Rng, srchRng As Word.Range
' Close MS Word if it's already opened
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Not objWord Is Nothing Then
objWord.Quit SaveChanges:=0
Set objWord = Nothing
End If
'Open MS Word
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
' Folder Location
myPath = "C:UsersDELLDocumentsTest"
' Input File
Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
' Output File
Set newwrdDoc = wrdApp.Documents.Add
myPath1 = myPath & "newdoc1.docx"
' Text you want to search
Dim FindWord As String
Dim result As String
FindWord = ""
'Style
mystyle = "Heading 1"
'Defines selection for Word's find function
wrdDoc.SelectAllEditableRanges
' Find Functionality in MS Word
With wrdDoc.ActiveWindow.Selection.Find
.Text = FindWord
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If mystyle <> "" Then
.Style = mystyle
End If
End With
' Execute find method
wrdDoc.ActiveWindow.Selection.Find.Execute
' Store Selected text
result = wrdDoc.ActiveWindow.Selection.Text
' Check if result contains non-blank text
If Len(result) > 1 Then
' -------------------------------------------------------------
' Loop through multiple find content (Find All functionality)
' -------------------------------------------------------------
While wrdDoc.ActiveWindow.Selection.Find.Found
wrdDoc.ActiveWindow.Selection.Copy
'Activate the new document
newwrdDoc.Activate
'New Word Doc
Set Rng = newwrdDoc.Content
Rng.Collapse Direction:=wdCollapseEnd
Rng.Paste
'Word Document
wrdDoc.Activate
wrdDoc.ActiveWindow.Selection.Find.Execute
Wend
' If style not found
Else
MsgBox "Text Not Found"
End If
'Close and don't save application
wrdDoc.Close SaveChanges:=False
'Save As New Word Document
newwrdDoc.SaveAs myPath1
newwrdDoc.Close SaveChanges:=False
'Close all word documents
wrdApp.Quit SaveChanges:=0
'Message when done
MsgBox "Task Accomplished"
End Sub
How to use the above program
- Open Excel Workbook
- Press ALT + F11 shortcut key to open visual basic editor (VBE)
- To insert a module, go to Insert > Module
- Paste the complete VBA script below
- Specify the path of folder in
myPathvariable. It is the folder location where your input word document file is stored. Make sure to mention backward slash at the end.myPath = "C:UsersDELLDocumentsTest" - Specify file name of your input MS Word document
Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx") - File name you wish to have in your output file. New word doc will be saved with this name.
myPath1 = myPath & "newdoc1.docx" - Type word(s) you want to seach in Find box. Keep it blank if you want to search by style only.
FindWord = "". - Specify style specific to your word document in
mystyle = "Heading 1".
How this program works
In this section we broken down the code into multiple snippets to make you understand how it works.
1. First we are closing word documents if any of them is already opened. It is to avoid conflict interacting Excel with Word. This is a useful technique in terms of error handling in the code as sometimes code may crash because of multiple word documents being opened at the same time.
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Not objWord Is Nothing Then
objWord.Quit SaveChanges:=0
Set objWord = Nothing
End If
2. In this section of code we are opening the input word document.
'Open MS Word
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
' Folder Location
myPath = "C:UsersDELLDocumentsTest"
' Input File
Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
3. Here we are adding a new word document in which we want to copy the content.
Set newwrdDoc = wrdApp.Documents.Add
myPath1 = myPath & "newdoc1.docx"
4. User need to mention the word or style he/she wants MS Word to look for.
' Text you want to search
Dim FindWord As String
Dim result As String
FindWord = ""
'Style
mystyle = "Heading 1"
5. This part of the VBA code refers to Find feature in MS Word. Many of us enable this functionality by hitting CTRL + F shortcut key. While ... Wend is an alternative of Do While Loop. Here it is used to find all the words which are formatted as ‘Heading 1’ style. It is to find all the searched results in iterative manner. After copying the text it goes to the last filled content in the output doc and then paste the content after that.
With wrdDoc.ActiveWindow.Selection.Find
.Text = FindWord
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If mystyle <> "" Then
.Style = mystyle
End If
End With
' Execute find method selects the found text if found
wrdDoc.ActiveWindow.Selection.Find.Execute
While wrdDoc.ActiveWindow.Selection.Find.Found
wrdDoc.ActiveWindow.Selection.Copy
'Activate the new document
newwrdDoc.Activate
'New Word Doc
Set Rng = newwrdDoc.Content
Rng.Collapse Direction:=wdCollapseEnd
Rng.Paste
'Word Document
wrdDoc.Activate
wrdDoc.ActiveWindow.Selection.Find.Execute
Wend
6. Last thing which is extremely important is to save the files and close MS Word application. We are closing the input file without saving any changes but the output file is saved with all the changes we made.
'Close and don't save application
wrdDoc.Close SaveChanges:=False
'Save As New Word Document
newwrdDoc.SaveAs myPath1
newwrdDoc.Close SaveChanges:=False
'Close all word documents
wrdApp.Quit SaveChanges:=0
Copy text from one word document to already created word document
Suppose you don’t want to create a new word document. Instead you wish to save it in the existing word doc you have. Assuming name of the output file is newdoc1.docx.
Replace this line of code Set newwrdDoc = wrdApp.Documents.Add with the code below.
Set newwrdDoc = wrdApp.Documents.Open(myPath & "newdoc1.docx")
If you wish to save the file with the new name you can change in this line of code.
myPath1 = myPath & "newdoc1_updated.docx"
Find specific text and then copy the next 3 words or characters
Specify the word(s) you want to find in FindWord = "Text you wish to search" and make style blank in
mystyle = ""
Replace this line of code wrdDoc.ActiveWindow.Selection.Copy with the code below.
Next 3 words
lngStart = wrdDoc.ActiveWindow.Selection.End
wrdDoc.ActiveWindow.Selection.MoveRight Unit:=wdWord, Count:=3, Extend:=wdExtend
wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
lngEnd = wrdDoc.ActiveWindow.Selection.Start
wrdDoc.Range(lngStart, lngEnd).Copy
wrdDoc.ActiveWindow.Selection.EndOf
Next 3 Characters
lngStart = wrdDoc.ActiveWindow.Selection.End
wrdDoc.Range(lngStart, lngStart + 3).Copy
If there are some spaces you may find the code extracts only 2 characters (or words) rather than 3 so you can increase the number from 3 to 4 in the code above
Copy text between two words
Suppose you wish to pull all the text between two words (or headings). In the code below you can specify the words in FindWord1 and FindWord2 variables.
Sub CopyBetweenTexts()
' Objects
Dim wrdApp, objWord As Object
Dim wrdDoc, newwrdDoc As Object
Dim myPath As String, myPath1 As String
Dim numberStart As Long
Dim Rng, srchRng As Word.Range
' Close MS Word if it's already opened
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Not objWord Is Nothing Then
objWord.Quit SaveChanges:=0
Set objWord = Nothing
End If
'Open MS Word
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
' Folder Location
myPath = "C:UsersDELLDocumentsTest"
' Input File
Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
' Output File
Set newwrdDoc = wrdApp.Documents.Add
myPath1 = myPath & "newdoc1.docx"
' Text you want to search
Dim FindWord1, FindWord2 As String
Dim result As String
FindWord1 = "Steps : PD Calibration"
FindWord2 = "Test2 Steps : PD Calibration"
'Style
mystyle = ""
'Defines selection for Word's find function
wrdDoc.SelectAllEditableRanges
' Move your cursor to the start of the document
wrdDoc.ActiveWindow.Selection.HomeKey unit:=wdStory
'Find Functionality in MS Word
With wrdDoc.ActiveWindow.Selection.Find
.Text = FindWord1
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If mystyle <> "" Then
.Style = mystyle
End If
If .Execute = False Then
MsgBox "'Text' not found.", vbExclamation
Exit Sub
End If
' Locate after the ending paragraph mark (beginning of the next paragraph)
' wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
' Starting character position of a selection
lngStart = wrdDoc.ActiveWindow.Selection.End 'Set Selection.Start to include searched word
.Text = FindWord2
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Style = mystyle
If .Execute = False Then
MsgBox "'Text2' not found.", vbExclamation
Exit Sub
End If
lngEnd = wrdDoc.ActiveWindow.Selection.Start 'Set Selection.End to include searched word
End With
'Copy Selection
wrdDoc.Range(lngStart, lngEnd).Copy
'Activate the new document
newwrdDoc.Activate
'New Word Doc
Set Rng = newwrdDoc.Content
Rng.Collapse Direction:=wdCollapseEnd
Rng.Paste
'Word Document
wrdDoc.Activate
wrdDoc.ActiveWindow.Selection.Find.Execute
'Close and don't save application
wrdDoc.Close SaveChanges:=False
'Save As New Word Document
newwrdDoc.SaveAs myPath1
newwrdDoc.Close SaveChanges:=False
'Close all word documents
wrdApp.Quit SaveChanges:=0
'Message when done
MsgBox "Task Accomplished"
End Sub
Find multiple different texts and copy in loop
If you wish to extract content between a couple of texts in iterative manner and then copy them one by one in another word document.
Here we assume texts are stored in column B starting from cell B3. See the image below.
Sub CopyBetweenTexts2()
' Objects
Dim wrdApp, objWord As Object
Dim wrdDoc, newwrdDoc As Object
Dim myPath As String, myPath1 As String
Dim numberStart As Long
Dim Rng, srchRng As Word.Range
' Close MS Word if it's already opened
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If Not objWord Is Nothing Then
objWord.Quit SaveChanges:=0
Set objWord = Nothing
End If
'Open MS Word
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
' Folder Location
myPath = "C:UsersDELLDocumentsTest"
' Input File
Set wrdDoc = wrdApp.Documents.Open(myPath & "PD Calibration.docx")
' Output File
Set newwrdDoc = wrdApp.Documents.Add
myPath1 = myPath & "newdoc1.docx"
' Text you want to search
Dim FindWord1, FindWord2 As String
Dim result As String
' Find last used cell in column B
Dim last As Double
With ActiveSheet
last = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
' Loop through column B
j = last - 2
For i = 1 To j
FindWord1 = Cells(2 + i, 2).Value
FindWord2 = Cells(3 + i, 2).Value
'Style
mystyle = ""
'Defines selection for Word's find function
wrdDoc.SelectAllEditableRanges
' Move your cursor to the start of the document
wrdDoc.ActiveWindow.Selection.HomeKey unit:=wdStory
'Find Functionality in MS Word
With wrdDoc.ActiveWindow.Selection.Find
.Text = FindWord1
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If mystyle <> "" Then
.Style = mystyle
End If
If .Execute = False Then
MsgBox "'Text' not found.", vbExclamation
Exit Sub
End If
' Locate after the ending paragraph mark (beginning of the next paragraph)
' wrdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
' Starting character position of a selection
lngStart = wrdDoc.ActiveWindow.Selection.End 'Set Selection.Start to include searched word
.Text = FindWord2
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Style = mystyle
If .Execute = False Then
MsgBox "'Text2' not found.", vbExclamation
Exit Sub
End If
lngEnd = wrdDoc.ActiveWindow.Selection.Start 'Set Selection.End to include searched word
End With
If (i = j) Then
wrdDoc.ActiveWindow.Selection.EndOf
wrdDoc.ActiveWindow.Selection.EndKey unit:=wdStory
lngEnd = wrdDoc.ActiveWindow.Selection.End
End If
'Copy Selection
wrdDoc.Range(lngStart, lngEnd).Copy
'Activate the new document
newwrdDoc.Activate
'New Word Doc
Set Rng = newwrdDoc.Content
Rng.Collapse Direction:=wdCollapseEnd
Rng.Paste
Next i
'Word Document
wrdDoc.Activate
wrdDoc.ActiveWindow.Selection.Find.Execute
'Close and don't save application
wrdDoc.Close SaveChanges:=False
'Save As New Word Document
newwrdDoc.SaveAs myPath1
newwrdDoc.Close SaveChanges:=False
'Close all word documents
wrdApp.Quit SaveChanges:=0
'Message when done
MsgBox "Task Accomplished"
End Sub
Find Text and Replace All
Suppose you want to find a specific text and replace it with some text. If a text has more than 1 occurence, it should be dealt with. In other words, Replace All functionality should be enabled. Here we are replacing it in the output document after copying from input word document. Add the code below after line Next i . Specify text in .Text = and .Replacement.Text =
'Replace All Name
newwrdDoc.Activate
With newwrdDoc.ActiveWindow.Selection.Find
.Text = "Text 1"
.Replacement.Text = "Text 2"
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
newwrdDoc.ActiveWindow.Selection.Find.Execute Replace:=wdReplaceAll
About Author:
Deepanshu founded ListenData with a simple objective — Make analytics easy to understand and follow. He has over 10 years of experience in data science. During his tenure, he has worked with global clients in various domains like Banking, Insurance, Private Equity, Telecom and Human Resource.
Sub Макрос()
Dim ворд As Object, док As Object
Dim var
‘1. Запуск ворда.
Set ворд = CreateObject(Class:=»Word.Application»)
‘2. Открытие ворд-файла.
var = «C:UsersUserDesktopИсточник.docx»
Set док = ворд.Documents.Open(Filename:=var)
‘3. Копирование всего содержимого ворд-файла.
док.Range.Copy
‘4. Перемещение курсора-рамки в A1.
Range(«A1»).Select
‘5. Вставка скопированного в эксель на активный лист в активную ячейку.
ActiveSheet.PasteSpecial Format:=»HTML», Link:=False, DisplayAsIcon:=False
‘6. Очистка буфера обмена, чтобы во время закрытия экселя не было
‘ сообщения, предлагающего сохранить содержимое буфера обмена.
‘ Для этого в буфер копируется первый символ из ворд-файла.
док.Range.Characters(1).Copy
‘7. Закрытие ворд-файла и ворда.
док.Close SaveChanges:=False
ворд.Quit
End Sub
[свернуть]
The following code should output to .csv file.
Note! First, please add reference to the Microsoft Scripting Runtime dll (scrrun.dll):
From the VBA window Tools->References->Check Microsoft Scripting Runtime dll
Here is the code that works (you can create macro and place the code inside it):
Dim wordsArray, arrayElement
Dim delimiter As String
Dim fileName As String
Dim fso As FileSystemObject
Dim outputFile As textStream
'select all document's content
ActiveDocument.Select
'provide delimiter
delimiter = InputBox("Please enter delimiter to use")
'split the selected content and place it inside the array
wordsArray = Split(Selection.Text, delimiter)
'generate output file name
fileName = "C:Output.csv"
'create new FileSystem object and open text stream to write to
Set fs = New FileSystemObject
Set outputFile = fs.CreateTextFile(fileName, True) 'note file will be overwritten
'iterate through array and write to the file
For Each arrayElement In wordsArray
'Use the following code to place each word into separate COLUMN
'outputFile.Write (arrayElement) & ","
'Use the following code to place each word into separate ROW
outputFile.WriteLine (arrayElement)
Next
'close output stream
outputFile.Close
You can massage it based on your needs…
Hope this helps.
Вот так можно поместить содержимое определённых страниц из одного документа в другой (в данном случае помещается всё содержимое первой страницы одного документа в другой):
| Visual Basic | ||
|
Есть 2 вида разрывов страниц:
- вставленный вручную (Word 2003: Вставка — Разрыв… — новую страницу или новую колонку);
- устанавливаемый программой Word (его видно между страницами в режиме просмотра документа Обычный режим).
Каждая страница в документе Word всегда имеет Разрыв страницы: если ручной не установлен, то есть естественный разрыв страницы, если ручной установлен, то ручной есть.
Этот Разрыв страницы в VBA всегда занимает положение в начале страницы (хотя визуально в программе Word разрыв страницы, естественно, находится в самом конце страницы).
Основываясь на том, что Разрыв страницы по подсчётам VBA всегда находится вначале страницы и имеет свойство Range, можно определить диапазон, находящийся на страницах.
ActiveWindow — чтобы понять, что это такое, нужно сделать следующее:
Word 2003
— Окно — Новое. В результате на Панели задач Windows (в самом низу монитора) появится ещё одна кнопка документа: т.е. один и тот же документ может быть открыт несколько раз. Зачем это надо? Я этим никогда не пользовался за всё время работы с Word. Могу предположить, зачем это надо, — чтобы просматривать документ в разных местах одновременно: т.е. в одном окне можем смотреть начало документа, а в другом окне — конец документа и сравнивать что-то в них.
Panes — чтобы понять что такое Panes:
Word 2003
— вставьте сноску (Вставка — Ссылка — Сноска… — Вставить). В результате в документ будет вставлена сноска. Далее: Вид — Обычный — Вид — Сноски. В результате внизу появилось что-то — это и есть Pane: т.е. в данной ситуации у нас два Pane: первый Pane — это собственно документ, а второй Pane — это что-то, связанное со сносками.
У документа всегда есть один Pane — это собственно сам документ. И этот Pane имеет порядковый номер всегда 1 (Panes(1)).
Итак строку кода:
| Visual Basic | ||
|
можно прочитать так:
Активный документ — Активное окно — первая Pane — первая страница — первый разрыв на странице (кроме разрыва страницы на странице может быть ещё разрыв раздела) — место в документе, занимаемое этим разрывом страницы (или порядковый номер символа, находящегося вначале страницы. Порядковый номер считается сначала документа) — Start — начало разрыва страницы (начало и конец у разрыва страницы равны).
- Remove From My Forums
-
Question
-
Dear All,
Merry Xmas to Everyone on the Forum.
I have a question regarding Word VBA. I have multiple word files that I would like to merge their content into one file. I wonder how this can be done in Word VBA. I wrote a sample code that open and merge two files, one after another. But the content
won’t merge properly. When I run the code I only get the content of the second file. Where am I wrong? Thank you for your help Below is the code.Sub testpro()
Dim originalApp As Word.Application, tempApp As Word.Application, newApp As Word.Application
Dim originalDoc As Word.Document, tempDoc As Word.Document, newDoc As Word.Document
Dim myPath As String, myPath1 As String, myPath2 As String, myPath3 As String
myPath = ThisDocument.Path
myPath1 = myPath & «1.docx»
myPath2 = myPath & «2.docx»
myPath3 = myPath & «test.docx»
Set newApp = CreateObject(«Word.Application»)
Set newDoc = newApp.Documents.Add()
newApp.Visible = True
On Error Resume Next
Set originalApp = GetObject(, «Word.Application»)
Set originalDoc = originalApp.Documents.Open(myPath1)
On Error Resume Next
Set tempApp = GetObject(, «Word.Application»)
Set tempDoc = tempApp.Documents.Open(myPath2)
On Error Resume Next
originalDoc.Activate
Selection.WholeStory
Selection.Copy
newDoc.Activate
Selection.PasteAndFormat (wdPasteDefault)
tempDoc.Activate
Selection.WholeStory
Selection.Copy
newDoc.Activate
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=»2″
Selection.Find.ClearFormatting
With Selection.Find
.Text = «»
.Replacement.Text = «»
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.PasteAndFormat (wdPasteDefault)
ActiveDocument.SaveAs (myPath3)
originalDoc.Close
tempDoc.Close
newDoc.Close
Set originalDoc = Nothing
Set tempDoc = Nothing
Set newDoc = NothingEnd Sub
Answers
-
Where do you want to run this code? If you want to run it from within Word (which seems likely, since you refer to ThisDocument), there is no need to use CreateObject and GetObject at all. If you want to run it from another application, there is no need
to create three variables of type Word.Application — one is enough.Try this version (to be run in Word):
Sub testpro() Dim originalDoc As Document, tempDoc As Document, newDoc As Document Dim myPath As String, myPath1 As String, myPath2 As String, myPath3 As String Dim rng As Range myPath = ThisDocument.Path myPath1 = myPath & "1.docx" myPath2 = myPath & "2.docx" myPath3 = myPath & "test.docx" Set newDoc = Documents.Add Set originalDoc = Documents.Open(myPath1) Set tempDoc = Documents.Open(myPath2) originalDoc.Content.Copy Set rng = newDoc.Content rng.Collapse Direction:=wdCollapseEnd rng.Paste tempDoc.Content.Copy Set rng = newDoc.Content rng.Collapse Direction:=wdCollapseEnd rng.Paste newDoc.SaveAs myPath3 originalDoc.Close SaveChanges:=False tempDoc.Close SaveChanges:=False newDoc.Close SaveChanges:=False End Sub
Regards, Hans Vogelaar
-
Edited by
Thursday, December 27, 2012 11:51 AM
-
Marked as answer by
forestrock
Thursday, December 27, 2012 12:20 PM
-
Edited by