Copy Charts To Word Bookmarks

Hi Guys,

I have found a routine from an old post on this forum - Excel range into word bookmark range (sorry can't seem to link to the page).

Code:

---

' ' Proof of concept code that will take all the named values in
 ' the worsheet ResultTalbes and insert them into the document
 ' defined at the top of the sheet with using the vlaues for
 ' Target Word File, and Target Word Doc.
 '
 '
Option Explicit
 
Sub insertIntoWordBookmark()
    ' define error handler
    On Error GoTo ErrorHandler
    '
    ' resltValues is a collection of the names from the ResultTables
    ' worksheet
    Dim resultValues As Collection
    Set resultValues = New Collection
    ' resultValues is an excel name object as a member of the resultValues collection
    Dim resultValue As Excel.Name
    '
    ' declare and set the variable nms a the active workbooks
    ' names collection. The workbooks names collection contains
    ' all the workbook's named cell rangesthese will be used to
    ' insert the target word document.
    Dim nms As Excel.names
    Set nms = ActiveWorkbook.names
   
    '
    ' loop incrementer
    Dim i As Integer
   
    '
    ' create the word target document, the document is set later it the script
    Dim targetWord As Word.Document
    '
    ' loop through excel named ranges and set the name of the bookmarks that
    ' will be updated are only from the worksheet named Result Tables
    For i = 1 To nms.Count
        'copy range value
        '    If nms(i).RefersToRange.Parent.Name = "ResultTables" Then
        resultValues.add Item:=nms(i), Key:=nms(i).Name
        '    End If
    Next i
    '
    '
    ' create and set the word application object
    Dim appWord As Word.Application
    Set appWord = New Word.Application
    ' open word doc
    Dim pathToWord As String
    pathToWord = Range("targetWordDir") & Range("targetWordFile")
    Set targetWord = appWord.Documents.add(pathToWord)
   
    '
    ' loop through the word document and create a temporary collection
    ' of the documents original bookmarks, the script will delete any
    ' new bookmarks that are introduce by the insertion process.
    Dim oBookmarks As Collection
    Dim oBookmark As Word.bookmark
    Dim delete As Boolean
    '
    Set oBookmarks = New Collection
    For Each oBookmark In targetWord.Bookmarks
        oBookmarks.add Item:=oBookmark, Key:=oBookmark.Name
    Next oBookmark
    '
    ' loop through our results and paste into word
    For Each resultValue In resultValues
        If targetWord.Bookmarks.Exists(resultValue.Name) Then
            ' determine if the source area in Excel is a single cell range, or a
            ' multiple cell range.
            If resultValue.RefersToRange.Count > 1 Then
                ' we have a table
                insertTable targetWord, resultValue
            ElseIf resultValue.RefersToRange.Count = 1 Then
                ' we have a value
                insertValue targetWord, resultValue
            End If
        End If
    Next resultValue
   
   
    '
    ' clean up any introduced bookmarks
    Dim targetBookmark As Word.bookmark
    For Each targetBookmark In targetWord.Bookmarks
        delete = True
        For Each oBookmark In oBookmarks
            If UCase(oBookmark.Name) = UCase(targetBookmark.Name) Then
                delete = False
                ' found a match break out of loop
                Exit For
            End If
        Next oBookmark
        ' delete bad bookmark
        If delete Then
            targetBookmark.delete
        End If
    Next targetBookmark
    '
    ' activate word document
    With appWord
        .Visible = True
        .ActiveWindow.WindowState = 1
        .Activate
    End With
   
   
ErrorExit:
    Set appWord = Nothing
    Set targetWord = Nothing
    Exit Sub
   
    'Error Handling routine
ErrorHandler:
    If Err Then
        MsgBox "Error No: " & Err.Number & ". " & Err.Description
        If Not appWord Is Nothing Then
            appWord.Quit False
        End If
        Resume ErrorExit
    End If
End Sub
 ' inserts a single cell range excel value into a word document "targetWord" at
 ' the insertion point bookmarkName
Sub insertValue(targetWord As Word.Document, bookmarkName As Excel.Name)
   
    Dim myRange As Word.Range
    '
    ' check that the bookmark exists in both excel and word
    If targetWord.Bookmarks.Exists(bookmarkName.Name) Then
        '
        ' activate the word doucment, got and update the current bookmark
        Set myRange = targetWord.Bookmarks(bookmarkName.Name).Range
        '
        ' redefine the text value of the range
        myRange.Text = bookmarkName.RefersToRange.Text
        '
        ' redefine the bookmark because it is destroyed when the value
        ' is changed.
        myRange.Bookmarks.add Name:=bookmarkName.Name
    End If
End Sub
 ' pastes a range of excel values into a word document "targetWord" at
 ' the insertion point bookmarkName
Sub insertTable(targetWord As Word.Document, bookmarkName As Excel.Name)
    '
    ' this is the range of the insertion point in the target document
    Dim myRange As Word.Range
    Dim newRange As Word.Range
    '
    ' check that the bookmark exists in both excel and word
    If targetWord.Bookmarks.Exists(bookmarkName.Name) Then
        '
        ' set target range, cordinates of the insertion point in the word document
        Set myRange = targetWord.Bookmarks(bookmarkName.Name).Range
        '
        ' check if we are in a table
        If myRange.Information(wdWithInTable) Then
            ' if so, delete the table
            myRange.Tables(1).delete
        End If
        '
        ' copy the result table from xl
        Range(bookmarkName.Name).Copy
        '
        ' collapse range so our insertions don't overlap with ranges
        myRange.Collapse Direction:=wdCollapseStart
        '
        ' The myRangeStart variable is used to store the static location of the start
        ' position of the myRange. When the paste method is executed the start position
        ' changes and the original is needed to reset the bookmark.
        Set newRange = targetWord.Range(myRange.Start, myRange.Start)
        '
        ' paste table
        myRange.PasteSpecial Link:=False, DataType:=wdPasteHTML
        '
        ' reset target bookmark
        targetWord.Bookmarks.add Name:=bookmarkName.Name, Range:=newRange
    End If
End Sub

---

The code copies text/tables from named ranges into a word document with bookmarks of the same name. I would like to extend on this to also copy any charts to the bookmarks at the same time. Is this achievable or is there an alternative solution somebody could suggest?

Thanks in advance.

Pasting charts to Word is quite straightforward:

Code:

---

Sub Demo()
'Note: A reference to the Word library must be set, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document, xlShp As Excel.Shape
Const StrDocNm As String = "Full document name & path"
If Dir(StrDocNm) = "" Then Exit Sub
Set wdDoc = wdApp.Documents.Add(StrDocNm)
wdApp.Visible = True
With wdDoc
  For Each xlShp In ActiveWorkbook.ActiveSheet.Shapes
    If .Bookmarks.Exists(xlShp.Name) Then
      xlShp.Copy
      .Bookmarks(xlShp.Name).Range.Paste
    End If
  Next
End With
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

---

The above code is self-contained. It assumes the charts are named and that their names correspond with bookmark names in the document.

PS: My own coding style is quite different from that used for the code you posted and I don't have the time to study your code to integrate mine with it - or to re-write yours.

Thanks Macropod, I was able to adapt your code and incorporate it within the existing routine.

Full routine incase anybody finds this of benefit:

Code:

---

'
 ' Proof of concept code that will take all the named values in
 ' the worsheet ResultTalbes and insert them into the document
 ' defined at the top of the sheet with using the vlaues for
 ' Target Word File, and Target Word Doc.
 '
 '
Option Explicit
 
Sub InsertIntoWordBookmark()
    ' define error handler
    On Error GoTo ErrorHandler
    '
    ' resltValues is a collection of the names from the ResultTables
    ' worksheet
    Dim resultValues As Collection
    Set resultValues = New Collection
    ' resultValues is an excel name object as a member of the resultValues collection
    Dim resultValue As Excel.Name
    '
    ' declare and set the variable nms a the active workbooks
    ' names collection. The workbooks names collection contains
    ' all the workbook's named cell rangesthese will be used to
    ' insert the target word document.
    Dim nms As Excel.Names
    Set nms = ActiveWorkbook.Names
   
    '
    ' loop incrementer
    Dim i As Integer
   
    '
    ' create the word target document, the document is set later it the script
    Dim targetWord As Word.Document
    '
    ' loop through excel named ranges and set the name of the bookmarks that
    ' will be updated are only from the worksheet named Result Tables
    For i = 1 To nms.Count
        'copy range value
        '    If nms(i).RefersToRange.Parent.Name = "ResultTables" Then
        resultValues.Add Item:=nms(i), Key:=nms(i).Name
        '    End If
    Next i
    '
    '
    ' create and set the word application object
    Dim appWord As Word.Application
    Set appWord = New Word.Application
    ' open word doc
    Dim pathToWord As String
    pathToWord = ThisWorkbook.Path & "\Doc1.docx"
    Set targetWord = appWord.Documents.Add(pathToWord)
    '
    ' loop through the word document and create a temporary collection
    ' of the documents original bookmarks, the script will delete any
    ' new bookmarks that are introduce by the insertion process.
    Dim oBookmarks As Collection
    Dim oBookmark As Word.Bookmark
    Dim delete As Boolean
    '
    Set oBookmarks = New Collection
    For Each oBookmark In targetWord.Bookmarks
        oBookmarks.Add Item:=oBookmark, Key:=oBookmark.Name
    Next oBookmark
    '
    ' loop through our results and paste into word
    For Each resultValue In resultValues
        If targetWord.Bookmarks.Exists(resultValue.Name) Then
            ' determine if the source area in Excel is a single cell range, or a
            ' multiple cell range.
            If resultValue.RefersToRange.Count > 1 Then
                ' we have a table
                InsertTable targetWord, resultValue
            ElseIf resultValue.RefersToRange.Count = 1 Then
                ' we have a value
                InsertValue targetWord, resultValue
            End If
        End If
    Next resultValue
   
    'Copy charts to bookmarks
    InsertChart targetWord
    '
    ' clean up any introduced bookmarks
    Dim targetBookmark As Word.Bookmark
    For Each targetBookmark In targetWord.Bookmarks
        delete = True
        For Each oBookmark In oBookmarks
            If UCase(oBookmark.Name) = UCase(targetBookmark.Name) Then
                delete = False
                ' found a match break out of loop
                Exit For
            End If
        Next oBookmark
        ' delete bad bookmark
        If delete Then
            targetBookmark.delete
        End If
    Next targetBookmark
    '
    ' activate word document
    With appWord
        .Visible = True
        .ActiveWindow.WindowState = 1
        .Activate
    End With
       
ErrorExit:
    Set appWord = Nothing
    Set targetWord = Nothing
    Exit Sub
   
    'Error Handling routine
ErrorHandler:
    If Err Then
        MsgBox "Error No: " & Err.Number & ". " & Err.Description
        If Not appWord Is Nothing Then
            appWord.Quit False
        End If
        Resume ErrorExit
    End If
End Sub
 ' inserts a single cell range excel value into a word document "targetWord" at
 ' the insertion point bookmarkName
Sub InsertValue(targetWord As Word.Document, bookmarkName As Excel.Name)
   
    Dim myRange As Word.Range
    '
    ' check that the bookmark exists in both excel and word
    If targetWord.Bookmarks.Exists(bookmarkName.Name) Then
        '
        ' activate the word doucment, got and update the current bookmark
        Set myRange = targetWord.Bookmarks(bookmarkName.Name).Range
        '
        ' redefine the text value of the range
        myRange.Text = bookmarkName.RefersToRange.Text
        '
        ' redefine the bookmark because it is destroyed when the value
        ' is changed.
        myRange.Bookmarks.Add Name:=bookmarkName.Name
    End If
End Sub
 ' pastes a range of excel values into a word document "targetWord" at
 ' the insertion point bookmarkName
Sub InsertTable(targetWord As Word.Document, bookmarkName As Excel.Name)
    '
    ' this is the range of the insertion point in the target document
    Dim myRange As Word.Range
    Dim newRange As Word.Range
    '
    ' check that the bookmark exists in both excel and word
    If targetWord.Bookmarks.Exists(bookmarkName.Name) Then
        '
        ' set target range, cordinates of the insertion point in the word document
        Set myRange = targetWord.Bookmarks(bookmarkName.Name).Range
        '
        ' check if we are in a table
        If myRange.Information(wdWithInTable) Then
            ' if so, delete the table
            myRange.Tables(1).delete
        End If
        '
        ' copy the result table from xl
        Range(bookmarkName.Name).Copy
        '
        ' collapse range so our insertions don't overlap with ranges
        myRange.Collapse Direction:=wdCollapseStart
        '
        ' The myRangeStart variable is used to store the static location of the start
        ' position of the myRange. When the paste method is executed the start position
        ' changes and the original is needed to reset the bookmark.
        Set newRange = targetWord.Range(myRange.Start, myRange.Start)
        '
        ' paste table
        myRange.PasteSpecial Link:=False, DataType:=wdPasteHTML
        myRange.Tables(1).AutoFitBehavior (wdAutoFitWindow)
        '
        ' reset target bookmark
        targetWord.Bookmarks.Add Name:=bookmarkName.Name, Range:=newRange
    End If
   
    Application.CutCopyMode = False
End Sub
 ' pastes a chart from excel into a word document "targetWord" at
 ' the insertion point bookmarkName
Sub InsertChart(targetWord As Word.Document)
    Dim wdDoc As Word.Document, xlShp As Excel.Shape
   
    Set wdDoc = targetWord
   
    With wdDoc
        For Each xlShp In ActiveWorkbook.ActiveSheet.Shapes
            If .Bookmarks.Exists(xlShp.Name) Then
                xlShp.Copy
                .Bookmarks(xlShp.Name).Range.Paste
            End If
        Next
    End With
   
    Set wdDoc = Nothing
End Sub

---