Sub CellsToWord()
Const wdDoNotSaveChanges = 0
Dim objWordApp As Object
Dim objWordDoc As Object
Dim objWordSel As Object
Dim blnNewApp As Boolean
Dim blnError As Boolean
Dim cell As Excel.Range
On Error Resume Next
' Get reference to Word app if already open.
Set objWordApp = GetObject(, "Word.Application")
On Error GoTo ErrHandler
' Launch Word if it wasn't already open.
If objWordApp Is Nothing Then
Set objWordApp = CreateObject("Word.Application")
blnNewApp = True
End If
' Check that some cells are selected in Excel.
If Not TypeOf Selection Is Range Then
MsgBox "Select some cells first.", vbExclamation
GoTo ExitProc
End If
' Create new Word document and get a
' reference to the insertion point.
Set objWordDoc = objWordApp.Documents.Add
Set objWordSel = objWordApp.Selection
' Loop through the selected cells in Excel and type
' each cell's contents into a Word paragraph.
For Each cell In Selection.Cells
objWordSel.TypeText cell.Text
objWordSel.TypeParagraph
Next cell
' Make the Word app visible and
' change the focus to its window.
objWordApp.Visible = True
AppActivate objWordApp.Caption
ExitProc:
On Error Resume Next
' If we launched a new Word app and an
' error occurred, then close it.
If blnError Then
If blnNewApp Then
objWordApp.Quit wdDoNotSaveChanges
Else
objWordDoc.Close wdDoNotSaveChanges
End If
End If
Set objWordApp = Nothing
Set objWordDoc = Nothing
Set objWordSel = Nothing
Exit Sub
ErrHandler:
' If an error occurred, notify the user.
MsgBox Err.Description, vbExclamation
blnError = True
Resume ExitProc
End Sub