Pushing Charts and Ranges from Excel to Word

[Jacob Hilderbrand]

Ok, I added a bit to make you all happy.

 
' 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