vba code copy multiple excel charts to word - vba

Question

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

Answer 1

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