I am trying to write a code that copies the contents of multiple worksheets in a single workbook into a single word document. I want the content of each worksheet to be on its own page, but right now, my code is just copying and pasting over each other instead of going onto a new page and pasting. I've tried going to the end of the document but it isn't working... Any advice would be helpful.
Sub ToWord()
Dim ws As Worksheet
Dim Wkbk1 As Workbook
Set Wkbk1 = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
For Each ws In ActiveWorkbook.Worksheets
ws.Range("A1:A2").Copy
Dim wdapp As Object
Dim wddoc As Object
Dim Header As Range
Dim strdocname As String
'file name & folder path
On Error Resume Next
'error number 429
Set wdapp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
'create new instance of word application
Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
'define paths to file
strdocname = "C:\Doc.doc"
If Dir(strdocname) = "" Then
MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "C:\Doc.doc", vbExclamation, "The document does not exist "
Exit Sub
End If
wdapp.Activate
Set wddoc = wdapp.Documents(strdocname)
If wddoc Is Nothing Then Set wddoc = wdapp.Documents.Open(strdocname)
'must activate to be able to paste
wddoc.Activate
wddoc.Range.Paste
Next ws
'Clean up
Set wddoc = Nothing
Set wdapp = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
you can just use:
wddoc.Range(i).Paste
incrementing i by 1 after each image. that pastes them one after another.
or more simply:
wddoc.Range(wddoc.Characters.Count-1).Paste
then could get more complicated and add a page break manually in between each if images are small to ensure a new page for each:
wddoc.Range(wddoc.Characters.Count-1).InsertBreak Type:=7
https://msdn.microsoft.com/en-us/library/office/ff821608.aspx
EDIT
First, I incorrectly assumed the "wddoc.range" property would get wherever the cursor is. This is not true. You need to use the code provided by Miss Palmer (and replicated below).
However, there is an additional issue I didn't notice at first. Your loop is set incorrectly. You are looping through and continually reopening the word doc. You need to move these lines:
For Each ws In ActiveWorkbook.Worksheets
ws.Range("A1:A2").Copy
so that they are immediately above the
wddoc.Range(wddoc.Characters.Count - 1).Paste
line. This will cause the loop to be executed properly and only open the word doc once.
Also (again, per Miss Palmer), you want to put this:
wddoc.Range(wddoc.Characters.Count - 1).Paste
wddoc.Range(wddoc.Characters.Count - 1).InsertBreak (wdPageBreak)after the line:
instead of the ".range.paste" that you originially had.
The other issue with your "Selection" line is that you did not specify the application you wanted to use. This was using Excel's selection by default as it was being run from Excel.
This code assumes that you have a word document that doesn't have enough pages. Otherwise you could likely use the code you want, but it's unclear why you would have a blank word document with many pages. You'd still need to specify the app you want to move to the next page in, so put "wdapp." before the selection line.
http://word.tips.net/T000120_Jumping_to_the_Start_or_End_of_a_Document.html
Related
I'm performing several prints of embedded Word document witch has some fields linked to some cells, by my PrintOut macro, in a For..Next loop, as below.
I need after each print task, that the program wait for document to close and then doing the next print.
In this situation I receive error. Can anyone help ?
Sub contract()
Dim i As Integer
For i = 1 To 100
Cells(Sheets("SheetName").ListObjects("StaffInfo").ListRows.Count + 9, 8).Value = i
General.PrintIt ("EmbeddedDoc") 'Doc has many linked fields
Next i
End Sub
Print method
Sub PrintIt(P As String)
Dim objWord As Object
Dim ObjDoc As Object
Dim Oshp As Object
Application.ScreenUpdating = False
ActiveSheet.OLEObjects(P).Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = False
Set ObjDoc = objWord.ActiveDocument
ObjDoc.Fields.Update
For Each Oshp In ObjDoc.Content.ShapeRange
Oshp.TextFrame.TextRange.Fields.Update
Next
ObjDoc.PrintOut Background:=False
ObjDoc.PrintOut
objWord.Quit SaveChanges:=False
Application.ScreenUpdating = True
End Sub 'Print it
Introduced problem was solved by this code.
Above code do open and close embedded word document, 100 times, and that problem was happening in close document.
Exactly, I cant understand why closing document immediately after printout command that where after open and update fields, generating that error.
Thus I cleaned the problem ask!
By integrating "PrintIt" method in "Contract" method that is parent of that, without calling "PrintIt" for each document printout, embedded document opens each one, perform doc links updating and printing 100 times in for next loop and close word app and document, at last, each one too.
In short, I cant find reason of problem in several Open-Print-Close document in order immediately; But i change the algorithm to Open-Several print-Close and problem been cleaned!
Sub contract()
Application.ScreenUpdating = False
Sheets("SheetName").Unprotect
'Declare variables
Dim i As Integer
Dim objWord, ObjDoc As Object
'Core
ActiveSheet.OLEObjects("Contract").Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = False
Set ObjDoc = objWord.ActiveDocument
For i = 1 To 100
Cells(x, y).Value = i 'A specific cell that
' word embedded document fields are linked to
'corresponding fields they values change
'by changing this cell.
ObjDoc.Fields.Update
ObjDoc.PrintOut Background:=False
ObjDoc.PrintOut
Next i
objWord.Quit SaveChanges:=False
Sheets("SheetName").Protect AllowFiltering:=True
End Sub
I am trying to copy and paste multiple tables from excel to word but it's giving me Subscript out of range error when I am trying to define tbl. I found the codes online and is trying to modify the codes to suit my needs.
Sub ExcelTablesToWord_Modified()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim sheet As Excel.Worksheet
Dim tableName As String
With dict
.Add "TableA1", "TableA1"
.Add "TableA2", "TableA2"
.Add "TableB1", "TableB1"
.Add "TableB2", "TableB2"
.Add "TableC", "TableC"
.Add "TableD", "TableD"
.Add "TableE1", "TableE1"
.Add "TableE2", "TableE2"
.Add "TableF1", "TableF1"
.Add "TableF2", "TableF2"
'TODO: add the remaining WorksheetName/TableName combinations
End With
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
On Error GoTo 0
'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
For Each sheet In ActiveWorkbook.Worksheets
tableName = dict(sheet.Name)
'Copy Table Range from Excel
sheet.ListObjects(tableName).Range.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(tableName).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit the most-recently-pasted Table so it fits inside Word Document
myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
Next sheet
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Below will copy the first Table in every worksheet and paste into Word doc, regardless of the Table Name. The bookmark names in the Word doc assumed to be simply start at 1 with prefix "bookmark".
If specific Table names are really required, then create a Collection for the names, and loop through each Table in each Worksheet, if that table name is in the Collection then proceed to copy.
Option Base 1 'Force arrays to start at 1 instead of 0
Sub ExcelTablesToWord()
Dim oWS As Worksheet
Dim tbl As Excel.Range
Dim WordApp As Object ' Word.Application
Dim myDoc As Object ' Word.Document
Dim x As Long ' Integer
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")
If WordApp Is Nothing Then GoTo WordDocNotFound
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
If myDoc Is Nothing Then Set myDoc = WordApp.Documents.Open("a.docx")
If myDoc Is Nothing Then GoTo WordDocNotFound
'Loop Through and Copy/Paste Multiple Excel Tables
x = 1 ' For x = LBound(TableArray) To UBound(TableArray)
For Each oWS In ThisWorkbook.Worksheets
'Copy Table Range from Excel
'Set tbl = ThisWorkbook.Worksheets(x).ListObjects(TableArray(x)).Range
Set tbl = oWS.ListObjects(1).Range
If Not tbl Is Nothing Then
tbl.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks("bookmark" & x).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
'Autofit Table so it fits inside Word Document
myDoc.Tables(x).AutoFitBehavior 2 ' (wdAutoFitWindow)
x = x + 1
End If
Next
On Error GoTo 0
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
The code I had originally provided was based on your original model, in which the corresponding Worksheet, Table, and Bookmark in each set had a different name.
Now that you have ensured that the names of the objects in each set are identical (which is a better model), try the following procedure. The only difference is that the Scripting.Dictionary has been eliminated, and the Worksheet name is being used to provide both the name of the Table and the name of the Bookmark (since all three values match now).
As before, this one has also been tested in Excel/Word 2016, and is functioning as expected:
Public Sub ExcelTablesToWord_Modified2()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim sheet As Excel.Worksheet
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
On Error GoTo 0
'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
For Each sheet In ActiveWorkbook.Worksheets
'Copy Table Range from Excel
sheet.ListObjects(sheet.Name).Range.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(sheet.Name).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit the most-recently-pasted Table so it fits inside Word Document
myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
Next sheet
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
If you still receive the same error, then perhaps the Workbook is corrupted. In that case, try doing the following:
Create a new Workbook with one Worksheet
Rename the Worksheet so that its name matches the name of one of the Bookmarks in the Word document
Manually add a single, small, "testing-only" Table to the Worksheet (do not copy/paste one from the original Workbook)
Ensure that the Table's name is the same as the Worksheet's name
Copy/paste the above procedure into a new Module in that Workbook
Save the new Workbook
Ensure your Word document is open, and run the procedure
If that works, then you might consider recreating your entire original Workbook in the new Workbook. When doing so, if your datasets are large enough that you must copy/paste from the Original Workbook, use "Paste Special" with "Values Only" instead of just a normal Paste. Then, re-create any missing formatting manually. That way, it will be less likely that any corruption in the original Workbook will be transferred to the new one.
I have searched a fair bit on this and other forums but I can't get code to work. I know this is user error - I am learning/self-taught at this.
What I want is to copy a (admittedly large) table in a specific Excel worksheet into an already-open Word document, at a specific point. I have seen this done using a keyword search but I would prefer to use a bookmark (and I've made the bookmark thing work!) purely because it's not visible to the end user. I'm trying to automate the creation of a document as much as possible.
The below code works, but I can only get it to work when the Word document in question is closed. If I try to run this sub when the word doc is open, it just tries to re-open it and of course can't. I can't find a neat bit of code that allows me to paste data into an already-open document.
Also, I can make this work for one value, but not for a range (i.e. the table I want to paste).
Sub ExcelRangeToWord()
Dim objWord As Object
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Summary")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'open the word doc
objWord.Documents.Open "K:\Exeter Office\Quotebuilder project\testbed\test.docx" 'change as required
'pastes the value of cell I19 at the "heatlosses" bookmark
With objWord.ActiveDocument
.Bookmarks("heatlosses").Range.Text = ws.Range("I19").Value
End With
'Optimize Code
Set objWord = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
I'm trying to tackle this one step at a time, cos then I have half a chance of understanding things a bit better...
If I try and copy/paste a range, instead of just one value, I was using Currentregion to select all used cells surrounding B19:
With objWord.ActiveDocument
.Bookmarks("heatlosses").Range.Text = Range("B19").CurrentRegion
End With
All this does is paste the word "True" into Word.
I am baffled. Please, can anyone offer assistance?
Use the code below to achieve what you require:
Sub CopyToWord()
Dim wApp, wDoc
'Get the running word application
Set wApp = GetObject(, "Word.Application")
'select the open document you want to paste into
Set wDoc = wApp.documents("test.docx")
'copy what you want to paste from excel
Sheet1.Range("A1").copy
'select the word range you want to paste into
wDoc.bookmarks("heatlosses").Select
'and paste the clipboard contents
wApp.Selection.Paste
End Sub
I am copying Excel cell contents to a bookmark on a Form Edit restricted (2010) Word document but it will only paste if the protection is turned off.
The code I currently have to turn the protection on again afterwards errors. What is the correct code?
Is there a way to make this copy and paste without turning off the protection?
Second problem is that when the text is pasted to the bookmark the font is Red (if manually entered on the document it is in black). The Word default is set as black (I reset the default for good measure). Typing in a new document is in black, however, when Word opens the font icon shows red even though checking the default it is still shows black. Can I define the font colour in the VBA to override this issue until is is resolved or can you suggest a way to fix the Word default?
Sub Arzbericht_Brandstetter()
' x - Defined Cell Names - ARTBrandPATH , ARTBrandDOC
' Excel Word Bookmark
' x - Defined Cell Names - ARZKrankenhaus Text65
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Dim Wd As Object
Dim wdDoc As Object
Dim BrandstetterDoc As Object
Dim BrandstetterPath As String
Dim f As Boolean
BrandstetterPath = ActiveSheet.Range("ARTBrandPATH").Value & ActiveSheet.Range("ARTBrandDOC").Value & ".doc" ' x
' On Error Resume Next
Set BrandstetterDoc = GetObject(BrandstetterPath)
If BrandstetterDoc Is Nothing Then
Set Wd = GetObject(, "Word.Application")
If Wd Is Nothing Then
Set Wd = CreateObject("Word.Application")
If Wd Is Nothing Then
MsgBox "Failed to start Word!", vbCritical
Exit Sub
End If
f = True
End If
Set BrandstetterDoc = Wd.Documents.Open(BrandstetterPath)
If BrandstetterDoc Is Nothing Then
MsgBox "Failed to open Brandstetter Document!" & vbNewLine & _
" Check File Directory is correct", vbCritical
If f Then
Wd.Quit
End If
Exit Sub
End If
Wd.Visible = True
Else
With BrandstetterDoc.Parent
.Visible = True
.Activate
' Turn Protection OFF
With ActiveDocument
.Unprotect "xxxxx"
.Protect wdAllowOnlyRevisions, , Password:="xxxxx"
End With
BrandstetterDoc.Bookmarks("Text65").Range.Text = ws.Range("ARZKrankenhaus").Value
' Turn Protection ON (Restricted Editing)
' ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
End With
End If
End Sub
Because its a Formfield and not just a bookmark I changing the code as below which resolved the strange red font issue. I can now copy to the document protected.
From
BrandstetterDoc.Bookmarks("Text65").Range.Text = ws.Range("ARZKrankenhaus").Value
To
ActiveDocument.FormFields("Text65").Result = ws.Range("ARZKrankenhaus").Value
I'm trying to copy the values from a named range in Excel to a bookmark in Word. I found this code on the web that does it in Excel VBA, but I'm getting an Error 13.
Set pappWord = CreateObject("Word.Application")
Set docWord = pappWord.Documents.Add(Path)
'Loop through names in the activeworkbook
For Each xlName In wb.Names
'if xlName's name is existing in document then put the value in place of the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
End If
Next xlName
'Activate word and display document
With pappWord
.Visible = True
.ActiveWindow.WindowState = 0
.Activate
End With
I know that the line that is causing the error is:
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
What am i doing wrong? Also, how & where would I code so that I can export the doc to PDF?
Thanks in advance.
Note: I've already selected the reference to the Microsoft Word (version number 14) Object model in Excel
so I use it to accomplish this task but taking an image from formatted Excel table.
Sub FromExcelToWord()
Dim rg As Range
For Each xlName In wb.Names
If docWord.Bookmarks.Exists(xlName.Name) Then
Set rg = Range(xlName.Value)
rg.Copy
docWord.ActiveWindow.Selection.Goto what:=-1, Name:=xlName.Name
docWord.ActiveWindow.Selection.PasteSpecial link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
0, DisplayAsIcon:=False
End If
Next xlName
End Sub
Just curious... Why are you adding a document rather than opening the relevant doc which has the bookmarks? Try this code (I usually test the code before posting but I haven't tested this particular code. Just quickly wrote it)
Also I am using Late Binding so no reference to the Word Object Library is required.
Sub Sample()
Dim wb As Workbook
Dim pappWord As Object, docWord As Object
Dim FlName As String
Dim xlName As Name
FlName = "C:\MyDoc.Doc" '<~~ Name of the file which has bookmarks
'~~> Establish an Word application object
On Error Resume Next
Set pappWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set pappWord = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
Set docWord = pappWord.Documents.Open(FlName)
Set wb = ActiveWorkbook
For Each xlName In wb.Names
'if xlName's name is existing in document then put the value in place of the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName).Value
End If
Next xlName
'Activate word and display document
With pappWord
.Visible = True
.ActiveWindow.WindowState = 0
.Activate
End With
End Sub
EDIT
Changed
Range(xlName.Value)
to
Range(xlName).Value
Now the above code is TRIED AND TESTED :)