- Excel Version
- 365
- 2019
- 2016
- 2013
- 2011
- 2010
- 2007
It is not difficult to merge Excel data to Word documents, but this destroys the bookmarks, and if you find you want to redo the merge after you've substantially modified the Word document, that can be frustrating. I wanted a merge that could be repeated as often as required, which meant recreating the bookmarks after the copying was done.
Powerpoint is much more difficult because it has no bookmarks, and it doesn't even let you name the objects on a slide so you can address them in code.
And in both cases, I wanted something that was simple for anyone to set up without technical knowledge. So I wrote this code below. The concept is simple - to set it up, just give names to text, ranges and charts in Excel, and create matching names in Word bookmarks and in Powerpoint, as per instructions below.
I cannot guarantee it will work in every case, as it has had limited use.
Word code
Powerpoint code
Powerpoint is much more difficult because it has no bookmarks, and it doesn't even let you name the objects on a slide so you can address them in code.
And in both cases, I wanted something that was simple for anyone to set up without technical knowledge. So I wrote this code below. The concept is simple - to set it up, just give names to text, ranges and charts in Excel, and create matching names in Word bookmarks and in Powerpoint, as per instructions below.
I cannot guarantee it will work in every case, as it has had limited use.
Word code
VBA Code:
Option Explicit
'This code copies charts and tables to a Word document using BOOKMARKS
'The Word document must be open and active, ie the currently visible Word document
'To copy a table, give it a range name starting with tbl, and then insert a bookmark
'with this name in the Word document where you want the table to go, prefixing the name
'with tag_
'eg if the name of the table is tblPerf3Yrs, then you include the bookmark tag_tblPerf3Yrs
'Similarly with charts, you give the chart a name starting with "cht" (ensure you select
'the full chart and not just part of it, when giving it a name, the safest is to
'press Ctrl before clicking on the chart
'then you include a bookmark with this name in Word, again prefixed with tag_
'running the macro below should copy everything across
'Note this approach means that the same chart/table CANNOT be inserted more than once
'because Word does not allow duplicate bookmark names for obvious reasons
Dim WdApp As Object 'Word.Application
Dim doc As Object 'Word.Document
Dim t
'the master sub, this gets called from Excel
Public Sub MergeToWord()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'open Word
Set WdApp = Nothing
Set doc = Nothing
On Error Resume Next
Set WdApp = GetObject(, "Word.Application")
If err <> 0 Then
MsgBox "Check that your Word document is open "
Exit Sub
End If
'get active document
Set doc = WdApp.ActiveDocument
If err <> 0 Then
MsgBox "Error in connecting to current Word document: " & err.Message
Exit Sub
End If
On Error GoTo 0
'do tables and charts
'look up all relevant tags in word, and process them
ReDim B(WdApp.ActiveDocument.bookmarks.Count) As Object
Dim i As Long
'store bookmarks in an array, then process them one by one
'we can't loop through them because Word destroys them when the paste occurs
'the code below recreates them, but this throws the numbering out and makes
'ordinary looping difficult
'store bookmarks in an array
For i = 1 To WdApp.ActiveDocument.bookmarks.Count
Set B(i) = WdApp.ActiveDocument.bookmarks(i)
Next i
'process them
For i = 1 To UBound(B)
If InStr(1, B(i).Name, "tag_", vbTextCompare) = 1 Then
PasteToWord B(i)
End If
Next i
'activate Word so the user can check the results
WdApp.Activate
Set WdApp = Nothing
Application.StatusBar = False
t = Timer - t
End Sub
'process a Word tag
Private Sub PasteToWord(B As Object, Optional Method As String = "Metafile") 'tag As String)
On Error Resume Next
Dim strTag As String
Dim tag As String
tag = B.Name
strTag = Mid$(B.Name, 5)
If err <> 0 Then Exit Sub
On Error GoTo 0
'select bookmark range
B.Range.Select
'mark beginning of bookmark
Dim rngMark As Object
Set rngMark = WdApp.Selection.Range
'b.Range.Text = vbNullString
'b.Range.Delete
'choose whether to paste a table or chart, based on the tag name
If InStr(tag, "tag_tbl") > 0 Then
rngMark.Collapse 1
PasteTableToWord B
ElseIf InStr(tag, "tag_cht") > 0 Then
'b.Range.Text = vbNullString
'rngMark.Collapse 1
B.Range.Delete
'b.Range.Select
CopyChartToWord B, rngMark, Method
rngMark.End = WdApp.Selection.End
WdApp.ActiveDocument.bookmarks.Add tag, rngMark
ElseIf InStr(tag, "tag_txt") > 0 Then
rngMark.Collapse 1
PasteTextToWord B
ElseIf InStr(tag, "tag_pic") > 0 Then
rngMark.Collapse 1
PastePicToWord B
Else
Exit Sub
End If
If InStr(tag, "tag_cht") = 0 Then
'mark end of pasted stuff
rngMark.End = WdApp.Selection.End
'add bookmark again
WdApp.ActiveDocument.bookmarks.Add tag, rngMark
End If
'clean up
Cleanup:
Application.CutCopyMode = False
Application.StatusBar = False
End Sub
'paste text
'the word tag must exist as a range in Excel for this to work
Private Sub PasteTextToWord(B As Object)
Dim strTag As String
On Error Resume Next
strTag = Mid$(B.Name, 5)
If err <> 0 Then Exit Sub
On Error GoTo 0
Dim txtTag As String
Dim u As Long
txtTag = strTag
On Error Resume Next
Range(txtTag).Copy
If err = 0 Then
If InStr(1, txtTag, "txt", vbTextCompare) > 0 Then
With WdApp.Selection
.Select
.ClearContents
.PasteAndFormat (22)
End With
Else
With WdApp.Selection
.Select
.ClearContents
WdApp.Selection.PasteAndFormat (22)
End With
End If
Else
WdApp.ActiveDocument.Selection = "*** NOT FOUND ***"
End If
On Error GoTo 0
End Sub
Private Sub PastePicToWord(B As Object)
Dim strTag As String
On Error Resume Next
strTag = Mid$(B.Name, 5)
If err <> 0 Then Exit Sub
On Error GoTo 0
Dim txtTag As String
Dim u As Long
txtTag = strTag
'find chart
Dim w As Worksheet, pic As Picture
For Each w In ActiveWorkbook.Sheets
Set pic = w.Pictures(strTag)
If Not pic Is Nothing Then Exit For
Next w
If pic Is Nothing Then Exit Sub
On Error Resume Next
pic.Copy
If err = 0 Then
WdApp.Selection.Paste 'Special Link:=False, DataType:=8, Placement:=0 'shape, inline
End If
On Error GoTo 0
End Sub
'paste table
'the word tag must exist as a range in Excel for this to work
Private Sub PasteTableToWord(B As Object)
Dim strTag As String
On Error Resume Next
strTag = Mid$(B.Name, 5)
If err <> 0 Then Exit Sub
On Error GoTo 0
Dim tblTag As String
Dim u As Long
tblTag = strTag
On Error Resume Next
Range(tblTag).Copy
If err = 0 Then
If InStr(1, tblTag, "tbl", vbTextCompare) > 0 Then
With WdApp.Selection
.Tables(1).Select
.Tables(1).Delete
.PasteSpecial DataType:=1, Placement:=0 '9
'.PasteAndFormat (0) 'default paste
End With
Else
With WdApp.Selection
.Tables(1).Select
.Tables(1).Delete
WdApp.Selection.PasteAndFormat (22) 'plain text
End With
End If
Else
WdApp.ActiveDocument.Selection = "*** NOT FOUND ***"
End If
On Error GoTo 0
End Sub
'copy chart
'the chart name must be the same as the Word tag for this to work
'the chart must be in the current sheet
'Method can be any of the values listed below in the Select Case clause
Private Sub CopyChartToWord(B As Object, rngMark, Optional Method As String = "Metafile")
On Error Resume Next
Dim strTag As String
strTag = Mid$(B.Name, 5)
If err <> 0 Then Exit Sub
On Error GoTo 0
'find chart
Dim w As Worksheet, cht As ChartObject
For Each w In ActiveWorkbook.Sheets
Set cht = w.ChartObjects(strTag)
If Not cht Is Nothing Then Exit For
Next w
If cht Is Nothing Then Exit Sub
On Error Resume Next
cht.Copy
If err = 0 Then
Select Case Method
Case "Metafile"
rngMark.PasteSpecial DataType:=3, Placement:=0 'metafile, inline
Case "Enhanced metafile"
WdApp.Selection.PasteSpecial DataType:=9, Placement:=0 'metafile, inline
Case "Bitmap"
WdApp.Selection.PasteSpecial DataType:=4, Placement:=0 'metafile, inline
Case "Drawing"
WdApp.Selection.PasteSpecial link:=False, DataType:=8, Placement:=0 'shape, inline
Case "JPG"
Dim fName As String
fName = ThisWorkbook.Path & "\tmp.jpg"
cht.Chart.Export fName, "JPG"
WdApp.Selection.InlineShapes.AddPicture filename:=fName, LinkToFile:=False, SaveWithDocument:=True
Kill fName
End Select
Else
WdApp.ActiveDocument.Selection.Text = "*** NOT FOUND ***"
End If
On Error GoTo 0
End SubPowerpoint code
VBA Code:
Option Explicit
'This code copies charts and tables to a Powerpoint document, replacing existing objects
'The Word document must be open and active, ie the currently visible Word document
'To copy a table, give it a range name starting with tbl, and then insert a bookmark
'with this name in the Word document where you want the table to go, prefixing the name
'with tag_
'eg if the name of the table is tblPerf3Yrs, then you include the bookmark tag_tblPerf3Yrs
'Similarly with charts, you give the chart a name starting with "cht" (ensure you select
'the full chart and not just part of it, when giving it a name, the safest is to
'press Ctrl before clicking on the chart
'then you include a bookmark with this name in Word, again prefixed with tag_
'running the macro below should copy everything across
'Note this approach means that the same chart/table CANNOT be inserted more than once
'because Word does not allow duplicate bookmark names for obvious reasons
Dim PPTApp As Object 'pres.Application
Dim pres As Object 'pres.Document
Dim t
Sub ShowInstructions()
ThisWorkbook.Sheets("Merge Instructions").Copy
End Sub
'the master sub, this gets called from Excel
Public Sub MergeToPowerpoint()
Application.ScreenUpdating = False
t = Timer
'open PPT
Set PPTApp = Nothing
Set pres = Nothing
On Error Resume Next
Set PPTApp = GetObject(, "Powerpoint.Application")
If err <> 0 Then
MsgBox "Check that your Powerpoint presentation is open "
Exit Sub
End If
'get active document
Set pres = PPTApp.ActivePresentation
If err <> 0 Then
MsgBox "Error in connecting to current Powerpoint presentation: " & err.Message
Exit Sub
End If
On Error GoTo 0
'do tables and charts
'look up all relevant tags in PPT, and process them
Dim slide As Object
Dim shpPPT As Object
Dim sht As Worksheet, cht As ChartObject
Dim r As Range, shpXL As Shape, tag As String, found As Boolean, errorCount As Long
Dim C As New Collection, i As Long
For Each slide In pres.Slides
Do While C.Count > 0: C.Remove 1: Loop
For Each shpPPT In slide.Shapes
C.Add shpPPT, shpPPT.Name
Next
Retry:
For i = 1 To C.Count
tag = C(i).AlternativeText
If InStr(1, tag, "tag_", vbTextCompare) = 1 Then
'Debug.Print tag & ": ";
tag = Mid$(tag, 5)
found = False
On Error Resume Next
Range(tag).Copy
If err.Number = 0 Then found = True
On Error GoTo 0
If Not found Then
For Each sht In ThisWorkbook.Sheets
For Each shpXL In sht.Shapes
If shpXL.Name = tag Then
shpXL.Copy
found = True
Exit For
End If
Next shpXL
If found Then Exit For
Next sht
If Not found Then
For Each sht In ThisWorkbook.Sheets
For Each cht In ActiveSheet.ChartObjects
If cht.Name = tag Then
cht.CopyPicture Format:=xlPicture
found = True
Exit For
End If
Next cht
If found Then Exit For
Next sht
End If
End If
If found Then
On Error Resume Next
With slide.Shapes.PasteSpecial(DataType:=2, DisplayAsIcon:=0)
If err <> 0 Then
If errorCount < 5 Then
errorCount = errorCount + 1
'Beep
Debug.Print "Error = " & errorCount
GoTo Retry
Else
MsgBox "There was an error. Please try again", vbCritical
Exit Sub
End If
End If
On Error GoTo 0
.Top = C(i).Top
.Left = C(i).Left
.width = C(i).width
.Height = C(i).Height
C(i).Delete
.AlternativeText = "tag_" & tag
End With
Else
Debug.Print "not found"
End If
End If
Next i
Next slide
'activate PPT so the user can check the results
PPTApp.Activate
Set PPTApp = Nothing
Application.CutCopyMode = False
Cells(1, 1).Select
Application.StatusBar = False
t = Timer - t
End Sub
