Merging Excel to Word and Powerpoint

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 Sub

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