I am running an excel programme that generates graphs based on data. I then want to export it to word and save it as a pdf.
I am having issues with pasting the diagrams into word as I often get the error 'Run time error '4198' Command Failed' on the Word Paste Special line. I have included by code for the word export below.
Option Explicit
Sub word_export(numscans As Integer, rootpath As String, poleid As String)
Dim n As Integer
Dim i As Integer
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Set WDApp = CreateObject("Word.Application")
Set WDDoc = WDApp.Documents.Add
Application.Wait (Now + TimeValue("0:00:01"))
WDApp.DisplayAlerts = wdAlertsNone
For n = 1 To numscans
For i = 1 To Sheets("Scan" & n).ChartObjects.Count
Sheets("Scan" & n).ChartObjects(i).Chart.CopyPicture _
Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
WDApp.Selection.Range.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, DisplayAsIcon:=False
WDApp.Selection.MoveEnd wdStory
WDApp.Selection.Move
Next
Next
WDDoc.SaveAs rootpath & "\" & poleid & " Summary.pdf", wdFormatPDF
WDApp.Quit wdDoNotSaveChanges
Set WDDoc = Nothing
Set WDApp = Nothing
End Sub
Any help would be appreciated.
Not entirely sure about this one, but give it a go:
WDApp.Selection.Range.Select
WDApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, DisplayAsIcon:=False
Related
I have the below code that goes through a simple spreadsheet for now and paste the organisation,
one table a single cell value and a chart into a word template. The code runs and produces both a word and pdf version correctly. But what I see is that the table is on occasion ended up where the organisation should be and the chart is being repeated in the document. Each output of the loop seems to vary and I can't work out if the information is not being cleared from the clipboard before it gets pasted. Do I need to run the sections into sub sections or something?
Appreciate the help.
Sub CreateBasicWordReport()
Dim WdApp As Word.Application
Dim wdDoc As Word.Document
Dim SaveName As String
Dim FileExt As String
Dim LstObj1 As ListObject
Dim MaxValue As Integer
Dim FilterValue As Integer
Dim Organisation As String
Dim Rng As Range
Dim WS As Worksheet
Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
FilterValue = MaxValue
Set WdApp = CreateObject("Word.Application")
Do Until FilterValue = 0
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
Sheets("Sheet1").Select
'moved outside of loop
' Set WdApp = CreateObject("Word.Application")
With WdApp
.Visible = True
.Activate
'create new document and assign to object variable
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
'now mostly finished with WdApp as from here wdDoc is used
End With
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
Range("F11").Select
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
' .Selection.GoTo what:=-1, Name:="TableLocation"
' .Selection.Paste
wdDoc.Bookmarks("TableLocation").Range.Paste
For Each Row In Range("Table1[#All]").Rows
If Row.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = Row
Set Rng = Union(Row, Rng)
End If
Next Row
Set WS = Sheets("Static")
Rng.Copy Destination:=WS.Range("A1")
' Sheets("Static").Select
' Sheets("Static").Activate
Organisation = WS.Range("D2").Value
' Sheets("Static").Select
' Range("D2").Copy
WS.Range("D2").Copy
' .Selection.GoTo what:=-1, Name:="Organisation"
' .Selection.PasteAndFormat wdFormatPlainText
wdDoc.Bookmarks("Organisation").Range.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
' Sheets("Static").Select
' Range("F2").Copy
WS.Range("F2").Copy
' .Selection.GoTo what:=-1, Name:="MalePatients"
' .Selection.PasteAndFormat wdFormatPlainText
wdDoc.Bookmarks("MalePatients").Range.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
Chart2.ChartArea.Copy
' .Selection.GoTo what:=-1, Name:="ChartLocation"
' .Selection.Paste
wdDoc.Bookmarks("ChartLocation").Range.Paste
If WdApp.Version <= 11 Then
FileExt = ".doc"
Else
FileExt = ".docx"
End If
SaveName = Environ("UserProfile") & "\Desktop\Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & FileExt
If WdApp.Version <= 12 Then
' .ActiveDocument.SaveAs SaveName
wdDoc.SaveAs SaveName
Else
' .ActiveDocument.SaveAs2 SaveName
wdDoc.SaveAs2 SaveName
End If
SaveNamePDF = Environ("UserProfile") & "\Desktop\Report " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & ".pdf"
wdDoc.ExportAsFixedFormat _
OutputFileName:=SaveNamePDF, _
ExportFormat:=wdExportFormatPDF _
wdDoc.Close
FilterValue = FilterValue - 1
Sheets("Static").Delete
Application.DisplayAlerts = True
Loop
WdApp.Quit
Set WdApp = Nothing
End Sub
You may or may not want to take this as an answer to your question, but here are some ways you can improve your code so as to gain better control over how it operates. It is not a "solution" in the sense of a completed, correctly working code module, but if you adopt this advice it should enable you to solve the issue yourself (along with many other issues you might otherwise encounter in the future).
(1) Avoid using Copy and Paste. As you correctly note, those put you at the mercy of the Windows clipboard. Instead, assign the source object or value to a variable, then insert the contents of the variable at the destination. For instance:
Organisation = WS.Range("D2").Value
wdDoc.Bookmarks("Organisation").Range.Text = Organisation
Now you are able to control what is inserted at the destination point. Among other things, you can reset the variable at the end of each loop, so that there is no risk of repeatedly inserting an object or value that may be carried over from one loop cycle to the next.
(2) Use With ... End With to explicitly specify the parents of your objects. That way you don't risk accidentally referencing a different object than you expected. For instance, in this excerpt from your code ...
With WdApp
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
End With
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
... the range copied in the last line may not be what you expect. If the active object at the moment is your newly minted Word doc, the Range object may be interpreted as some range in the document, rather than the spreadsheet range you wanted to copy.
To stay in control, use With consistently:
With WdApp
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
End With
With MyWorkbook.Sheets("MySheet")
Set MyTableRange = .Range("A1", .Range("A1").End(xlDown).End(xlToRight))
End With
That's just a couple of pointers, but these are basic good coding practices that you should adopt. I think they will help you resolve the issues with your code.
The issues you are seeing are likely being caused by using the clipboard. There can be a delay when copying and pasting larger items, e.g. tables of data, charts.
When you use the clipboard you are passing some control over to the OS. VBA includes a function, DoEvents that passes control to the operating system. Control is then returned after the operating system has finished processing the events in its queue. By adding this after each copy/paste it should allow things to catch up.
You can also slightly reduce your use of the clipboard by setting the values for 'Organisation' and 'Male Patients' directly.
Sub CreateBasicWordReport()
Dim WdApp As Word.Application
Dim wdDoc As Word.Document
Dim SaveName As String
Dim FileExt As String
Dim LstObj1 As ListObject
Dim MaxValue As Integer
Dim FilterValue As Integer
Dim Organisation As String
Dim Rng As Range
Dim WS As Worksheet
Application.DisplayAlerts = False
Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
FilterValue = MaxValue
Set WdApp = CreateObject("Word.Application")
Do Until FilterValue = 0
Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
Sheets("Sheet1").Select
With WdApp
.Visible = True
.Activate
'create new document and assign to object variable
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\IBD Registry Quarterly Report Template2.dotx")
'now mostly finished with WdApp as from here wdDoc is used
End With
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
Range("F11").Select
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
wdDoc.Bookmarks("TableLocation").Range.Paste
DoEvents
For Each Row In Range("Table1[#All]").Rows
If Row.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = Row
Set Rng = Union(Row, Rng)
End If
Next Row
Set WS = Sheets("Static")
Rng.Copy Destination:=WS.Range("A1")
Application.CutCopyMode = False
DoEvents
Organisation = WS.Range("D2").Value
wdDoc.Bookmarks("Organisation").Range.Text = Organisation
wdDoc.Bookmarks("MalePatients").Range.Text = WS.Range("F2").Text
Chart2.ChartArea.Copy
wdDoc.Bookmarks("ChartLocation").Range.Paste
DoEvents
Application.CutCopyMode = False
If CLng(WdApp.Version) <= 11 Then
FileExt = ".doc"
Else
FileExt = ".docx"
End If
SaveName = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss")
SaveNamePDF = SaveName & ".pdf"
SaveName = SaveName & FileExt
If CLng(WdApp.Version) <= 12 Then
wdDoc.SaveAs SaveName
Else
wdDoc.SaveAs2 SaveName
End If
wdDoc.ExportAsFixedFormat _
OutputFileName:=SaveNamePDF, _
ExportFormat:=wdExportFormatPDF _
wdDoc.Close
FilterValue = FilterValue - 1
Sheets("Static").Delete
Application.DisplayAlerts = True
Loop
WdApp.Quit
Set WdApp = Nothing
End Sub
I have an embedded MS-Word document in an Excel Worksheet which name is SalaryPaycheck.
The MS-word document contains several linked fields to Worksheet cells.
I have update the linked cells, several times and perform updating above fields.
Then I need perform exporting the embedded MS-Word document each time the fields have updated, as PDF.
So I need all exported files are appending in a single pdf file.
I using below code:
Sub PrintIt()
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim i as Integer
ActiveSheet.OLEObjects("SalaryPaycheck").Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = False
Set objDoc = objWord.ActiveDocument
objWord.Application.DisplayAlerts = wdAlertsNone
objWord.Application.ScreenUpdating = False
For i = 1 to 10
Range("Key").value = i
objDoc.Fields.Update
objDoc.ExportAsFixedFormat _
outputfileName:=ThisWorkbook.path & "\Results\" & "rep" & i & ".pdf" _
, exportformat:=wdExportFormatPDF _
, openafterexport:=False _
, optimizefor:=wdExportOptimizeForPrint _
, Range:=wdExportAllDocument _
, Item:=wdExportDocumentContent _
, includedocprops:=False _
, keepirm:=True _
, createbookmarks:=wdExportCreateNoBookmarks _
, docstructuretags:=True _
, bitmapmissingfonts:=True _
, useiso19005_1:=False
Next i
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub 'Print it
How can using objDoc.SaveAs2 or objDoc.ExportAsFixedFormat (shown above) same as objDoc.PrintOut' whith 'Append:=True argument?
Or How can using .PrintOut with 'Append:=True' argument in this case (PDF) which working quietly (using OutputFileName:=path & filename and PrintToFile:=True)
As said in the other question, just append the documents in word
Sub PrintIt()
Dim objWord As Word.Application
Dim objDocTotal As Word.Document
Dim objDoc As Word.Document
Dim i As Integer
Dim strOutfile As String
Dim rg As Word.Range
ActiveSheet.OLEObjects("SalaryPaycheck").Activate
Set objWord = GetObject(, "Word.Application")
objWord.Visible = True
Set objDoc = objWord.ActiveDocument
Set objDocTotal = Documents.Add
objWord.Application.DisplayAlerts = wdAlertsNone
objWord.Application.ScreenUpdating = True
For i = 1 To 10
Range("Key").Value = i
With objDoc
.Fields.Update
.Content.Copy
End With
Set rg = objDocTotal.Content
With rg
.Collapse Direction:=wdCollapseEnd
If i > 1 Then .InsertBreak wdPageBreak
.PasteAndFormat wdFormatOriginalFormatting
End With
Next i
strOutfile = "<Path>\Salary.pdf"
objDocTotal.ExportAsFixedFormat outputfileName:= _
strOutfile, exportformat:=wdExportFormatPDF, _
openafterexport:=False, optimizefor:=wdExportOptimizeForPrint, Range:= _
wdExportAllDocument, From:=1, To:=1, Item:=wdExportDocumentContent
objDocTotal.Close False
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
End Sub
I have Excel VBA code that generates an Outlook e-mail with an attachment.
This worked in Windows 8.1 but does not work in Windows 10. I have stepped through the macro, and it gets all the way to the end, generates the e-mail, then fails on the OutMail.Send command. The error is
Runtime error 287 - Application-defined or object-defined error
Here is the code.
Sub batchallocationemail()
'define email & pdf
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim OutMail As Object
'
' print allocation Macro
'define worksheets
Dim ws As Worksheet
Set ws = Sheets("Caseworkers")
Dim ws2 As Worksheet
Set ws2 = Sheets("Allocation Sheet")
'define range
Dim NameRange As Range
Dim NameRange2 As Range
Dim x As Range
Dim z As Range
Set z = ws2.Range("B1")
Set NameRange = ws.Range("A1:C69")
Set NameRange2 = ws.Range("A2:A69")
Set NameRange3 = ws.Range("C2:C69")
'Selects name from list and pastes into allocation
ws.Select
NameRange.AutoFilter Field:=2, Criteria1:="In"
For Each x In NameRange2.SpecialCells(xlCellTypeVisible)
x.Copy
ws2.Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ws2.Select
'CONVERTS ACTIVE SHEET TO PDF AND EMAILS IT
' Define Title
Title = Range("B1").Value
' Define PDF filename
Title = "Allocation Sheet for " & Range("B1").Value
PdfFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Title & ".pdf"
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
' Prepare e-mail with PDF attachment
Set OutMail = OutlApp.CreateItem(0)
With OutMail
' Prepare e-mail
OutMail.Subject = Title
OutMail.To = x.Offset(0, 2).Value ' <-- Put email of the recipient here
OutMail.CC = x.Offset(0, 3).Value ' <-- Put email of 'copy to' recipient here
OutMail.Body = "Hello," & vbLf & vbLf _
& "Please see your attached allocation sheet in PDF format." & vbLf & vbLf _
& "Kind Regards," & vbLf _
& Application.UserName & vbLf & vbLf
OutMail.Attachments.Add PdfFile
' Try to send
Application.Visible = True
OutMail.Display
OutMail.Send
End With
' Quit Outlook if it was not already open
If IsCreated Then OutlApp.Quit
' Release the memory of object variable
Set OutMail = Nothing
Set OutlApp = Nothing
Next x
End Sub
sorry about this, i think I have fixed it. I posted this earlier after looking through for hours last night but I seem to have got it. Instead of .Send i used Application.SendKeys "%s" which is a shortcut. This seems to send the e-mail properly.
I'm new to VBA, have searched all over the place but can't seem to find a solution. I'm
getting a Run-time error 91: Object variable or With block variable not set error. Does anyone know why?
Much thanks.
Option Explicit
Sub Survey()
'Name of the existing Word doc.
Const stCoHydroSurveyTemplate As String = "Survey Template.docx"
'Define Word objects.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdbmHeadLossTable As Word.Range
Dim wdbmRevenueTable As Word.Range
'Define Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnHeadLossTable As Range
Dim rnRevenueTable As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
Set rnHeadLossTable = wsSheet.Range("HeadLossTable")
Set rnRevenueTable = wsSheet.Range("RevenueTable")
'Initialize the Word objets.
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "D:\Surveys" & stSurveyTemplate)
Set wdbmHeadLossTable = wdDoc.Bookmarks("HeadLossTable").Range
Set wdbmRevenueTable = wdDoc.Bookmarks("RevenueTable").Range
'If the macro has been run before, clean up any artifacts before trying to paste the table in again.
On Error Resume Next
With wdDoc.InlineShapes(1)
.Select
.Delete
End With
On Error GoTo 0
'Turn off screen updating.
Application.ScreenUpdating = False
'Copy the Head Loss Table to the clipboard.
rnHeadLossTable.Copy
rnRevenueTable.Copy
'Select the range defined by the "HeadLossTable" bookmark and paste in from the clipboard to the word doc "Survey Template".
With wdbmHeadLossTable
.Select
.PasteSpecial Link:=True, _
DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, _
DisplayAsIcon:=False
End With
With wdbmRevenueTable
.Select
.PasteSpecial Link:=True, _
DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, _
DisplayAsIcon:=False
End With
'Save and close the Word doc.
With wdDoc
.Save
.Close
End With
'Quit Word.
wdApp.Quit
'Null out your variables.
Set wdbmHeadLossTable = Nothing
Set wdbmRevenueTable = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
'Clear out the clipboard, and turn screen updating back on.
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "The Survey has successfully been " & vbNewLine & _
"transferred to " & stSurveyTemplate, vbInformation
End Sub
This line is incorrect:
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "D:\Surveys" & stSurveyTemplate)
Maybe you meant for it to be like this:
Set wdDoc = wdApp.Documents.Open("D:\Surveys" & stSurveyTemplate)
or this:
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\Surveys" & stSurveyTemplate)
What I noticed is that with the original code, it didn't throw an error and wdDoc was just set to Nothing. I removed the "sbBook.Path" and by mistake had an incorrect file name, and that did throw an error.
I'm using the VBA code here to copy all the charts and tables from an excel workbook into a new word document from a template which is pre-formatted with bookmarks (labeled Book1, Book2 etc). Unfortunately i only have a few tables but around 20 charts and if i leave a blank in the summary table for the ranges i get
Run-time error '5101':
Application-defined or object defined error
and it only copies and pastes over the charts and table before the gap.
This is my excel summary table:
Any idea how i can modify the code to prevent this?
Sorry - i'm a complete VBA noob
'You must set a reference to Microsoft Word Object Library from Tools | References
Option Explicit
Sub ExportToWord()
Dim appWrd As Object
Dim objDoc As Object
Dim FilePath As String
Dim FileName As String
Dim x As Long
Dim LastRow As Long
Dim SheetChart As String
Dim SheetRange As String
Dim BookMarkChart As String
Dim BookMarkRange As String
Dim Prompt As String
Dim Title As String
'Turn some stuff off while the macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Assign the Word file path and name to variables
FilePath = ThisWorkbook.Path
FileName = "WorkWithExcel.doc"
'Determine the last row of data for our loop
LastRow = Sheets("Summary").Range("A65536").End(xlUp).Row
'Create an instance of Word for us to use
Set appWrd = CreateObject("Word.Application")
'Open our specified Word file, On Error is used in case the file is not there
On Error Resume Next
Set objDoc = appWrd.Documents.Open(FilePath & "\" & FileName)
On Error Goto 0
'If the file is not found, we need to end the sub and let the user know
If objDoc Is Nothing Then
MsgBox "Unable to find the Word file.", vbCritical, "File Not Found"
appWrd.Quit
Set appWrd = Nothing
Exit Sub
End If
'Copy/Paste Loop starts here
For x = 2 To LastRow
'Use the Status Bar to let the user know what the current progress is
Prompt = "Copying Data: " & x - 1 & " of " & LastRow - 1 & " (" & _
Format((x - 1) / (LastRow - 1), "Percent") & ")"
Application.StatusBar = Prompt
'Assign the worksheet names and bookmark names to a variable
'Use With to group these lines together
With ThisWorkbook.Sheets("Summary")
SheetChart = .Range("A" & x).Text
SheetRange = .Range("B" & x).Text
BookMarkChart = .Range("C" & x).Text
BookMarkRange = .Range("D" & x).Text
End With
'Tell Word to goto the bookmark assigned to the variable BookMarkRange
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy
'Paste into Word
appWrd.Selection.Paste
'Tell Word to goto the bookmark assigned to the variable BookMarkChart
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
'Paste into Word
appWrd.Selection.Paste
Next
'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
'Let the user know the procedure is now complete
Prompt = "The procedure is now completed." & vbCrLf & vbCrLf & "www.VBAExpress.com"
Title = "Procedure Completion"
MsgBox Prompt, vbOKOnly + vbInformation, Title
'Make our Word session visible
appWrd.Visible = True
'Clean up
Set appWrd = Nothing
Set objDoc = Nothing
End Sub
full working code is below. I've modified the code so it pastes charts as enhanched metafiles because that's what my boss wants.
'You must set a reference to Microsoft Word Object Library from Tools | References
Option Explicit
Sub ExportToWord()
Dim appWrd As Object
Dim objDoc As Object
Dim FilePath As String
Dim FileName As String
Dim x As Long
Dim LastRow As Long
Dim SheetChart As String
Dim SheetRange As String
Dim BookMarkChart As String
Dim BookMarkRange As String
Dim Prompt As String
Dim Title As String
'Turn some stuff off while the macro is running
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
'Assign the Word file path and name to variables
FilePath = ThisWorkbook.Path
FileName = "WorkWithExcel.doc"
'Determine the last row of data for our loop
LastRow = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
'Create an instance of Word for us to use
Set appWrd = CreateObject("Word.Application")
'Open our specified Word file, On Error is used in case the file is not there
On Error Resume Next
Set objDoc = appWrd.Documents.Open(FilePath & "\" & FileName)
On Error GoTo 0
'If the file is not found, we need to end the sub and let the user know
If objDoc Is Nothing Then
MsgBox "Unable to find the Word file.", vbCritical, "File Not Found"
appWrd.Quit
Set appWrd = Nothing
Exit Sub
End If
'Copy/Paste Loop starts here
For x = 2 To LastRow
'Use the Status Bar to let the user know what the current progress is
Prompt = "Copying Data: " & x - 1 & " of " & LastRow - 1 & " (" & _
Format((x - 1) / (LastRow - 1), "Percent") & ")"
Application.StatusBar = Prompt
'Assign the worksheet names and bookmark names to a variable
'Use With to group these lines together
With ThisWorkbook.Sheets("Summary")
SheetChart = .Range("A" & x).Text
SheetRange = .Range("B" & x).Text
BookMarkChart = .Range("C" & x).Text
BookMarkRange = .Range("D" & x).Text
End With
If Len(BookMarkRange) > 0 Then
'Tell Word to goto the bookmark assigned to the variable BookMarkRange
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy
'Paste into Word
appWrd.Selection.Paste
End If
If Len(BookMarkChart) > 0 Then
'Tell Word to goto the bookmark assigned to the variable BookMarkChart
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
'Paste into Word
'appWrd.Selection.PasteSpecial ppPasteEnhancedMetafile
appWrd.Selection.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
Placement:=wdInLine, DisplayAsIcon:=False
End If
Next
'Turn everything back on
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
'Let the user know the procedure is now complete
Prompt = "The procedure is now completed." & vbCrLf & vbCrLf & "www.VBAExpress.com"
Title = "Procedure Completion"
MsgBox Prompt, vbOKOnly + vbInformation, Title
'Make our Word session visible
appWrd.Visible = True
'Clean up
Set appWrd = Nothing
Set objDoc = Nothing
End Sub
There are multiple problems with this code, including the fact that if you had more ranges than charts it would only copy as many ranges as there was charts.
But to quickly fix your problem, replace
'Tell Word to goto the bookmark assigned to the variable BookMarkRange
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy
'Paste into Word
appWrd.Selection.Paste
'Tell Word to goto the bookmark assigned to the variable BookMarkChart
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
'Paste into Word
appWrd.Selection.Paste
with
if len (BookMarkRange) > 0 then
'Tell Word to goto the bookmark assigned to the variable BookMarkRange
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy
'Paste into Word
appWrd.Selection.Paste
end if
if len(BookMarkChart) > 0 then
'Tell Word to goto the bookmark assigned to the variable BookMarkChart
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
'Copy the data from Thisworkbook
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
'Paste into Word
appWrd.Selection.Paste
end if