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
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
FilePath = ThisWorkbook.Path
FileName = "WorkWithExcel.doc"
LastRow = Sheets("Summary").Range("A65536").End(xlUp).Row
Set appWrd = CreateObject("Word.Application")
On Error Resume Next
Set objDoc = appWrd.Documents.Open(FilePath & "\" & FileName)
On Error GoTo 0
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
For x = 2 To LastRow
Prompt = "Copying Data: " & x - 1 & " of " & LastRow - 1 & " (" & _
Format((x - 1) / (LastRow - 1), "Percent") & ")"
Application.StatusBar = Prompt
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
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkRange
ThisWorkbook.Sheets(SheetRange).UsedRange.Copy
appWrd.Selection.Paste
appWrd.Selection.Goto What:=wdGoToBookmark, Name:=BookMarkChart
ThisWorkbook.Sheets(SheetChart).ChartObjects(1).Copy
appWrd.Selection.Paste
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.StatusBar = False
Prompt = "The procedure is now completed." & vbCrLf & vbCrLf & "www.VBAExpress.com"
Title = "Procedure Completion"
MsgBox Prompt, vbOKOnly + vbInformation, Title
appWrd.Visible = True
Set appWrd = Nothing
Set objDoc = Nothing
End Sub
|