'http://vbaexpress.com/forum/showthread.php?p=185718
Sub ExportFinalColumnToWord()
Dim wdApp As Word.Application
Dim myDoc As Word.Document
Dim mywdRange As Word.Range
Dim MyColumnA As Excel.Range
Dim MyColumnB As Excel.Range
Dim MyColumnC As Excel.Range
Dim MyColumnD As Excel.Range
Dim doc As String
doc = "x:\msword\MyFile.doc"
If Dir(doc) = "" Then
MsgBox "Error, file does not exist." & vbLf & doc, vbCritical, "File is Missing"
Exit Sub
End If
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo errorHandler
Set myDoc = wdApp.Documents.Add(Template:=doc)
wdApp.Visible = True
GoTo errorExit
Set MyColumnA = Sheets("MySheet").Range("A1").End(xlDown).Select
Set MyColumnB = Sheets("MySheet").Range("B1").End(xlDown).Select
Set MyColumnC = Sheets("MySheet").Range("C1").End(xlDown).Select
Set MyColumnD = Sheets("MySheet").Range("D1").End(xlDown).Select
With myDoc.Bookmarks
.Item("bmMyColumnA").Range.InsertAfter MyColumnA
.Item("bmMyColumnB").Range.InsertAfter MyColumnB
.Item("bmMyColumnC").Range.InsertAfter MyColumnC
.Item("bmMyColumnD").Range.InsertAfter MyColumnD
End With
Set wdApp = Nothing
Set myDoc = Nothing
Set mywdRange = Nothing
Exit Sub
errorExit:
On Error Resume Next
Set wdApp = Nothing
Set myDoc = Nothing
Set mywdRange = Nothing
Exit Sub
errorHandler:
MsgBox "Unexpected error: " & Err.Number & vbLf & Err.Description
Resume errorExit
End Sub
'or.....
Sub CopytoWord()
'Requires Tools > References > Microsoft Word 11.0 Object Library
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim doc As String
doc = "x:\msword\MyFile.doc"
If Dir(doc) = "" Then
MsgBox "Error, file does not exist." & vbLf & doc, vbCritical, "File is Missing"
Exit Sub
End If
On Error GoTo errorHandler
Set wdApp = New Word.Application
With wdApp
'Add makes a copy like from a template even though it may be a DOC file.
Set wdDoc = .Documents.Add(Template:=doc)
'Set wdDoc = .Documents.Open(doc)
.Visible = True
End With
With wdDoc.Bookmarks
.Item("testbm").Range.InsertAfter Worksheets("Sheet1").Range("A1").Value
End With
errorExit:
Set wdDoc = Nothing
Set wdApp = Nothing
Exit Sub
errorHandler:
MsgBox "Unexpected error: " & Err.Number & vbLf & Err.Description
Resume errorExit
End Sub