Option Explicit
Private Sub CommandButton3_Click()
Const wdSaveChanges = -1
Dim objWordApp As Object
Dim objWordDoc As Object
Dim objWordRange As Object
Dim vntElem As Variant
Dim avntArray As Variant
Dim strText As String
Set objWordApp = fncObjOffApp(pvstrApp:="Word")
With objWordApp
.Visible = True
Set objWordDoc = .Documents.Add
End With
Set objWordRange = objWordDoc.Content
With Worksheets("Sheet2")
avntArray = .Cells(2, 1).Resize(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)
End With
For Each vntElem In avntArray
strText = strText & vntElem & Chr(10)
Next
objWordRange.InsertAfter Text:=strText
Set objWordApp = Nothing
Set objWordDoc = Nothing
Set objWordRange = Nothing
End Sub
Private Function fncObjOffApp(ByVal pvstrApp As String) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(Class:=pvstrApp & ".Application")
If Err.Number = 429 Then
Err.Clear
Set objApp = CreateObject(pvstrApp & ".Application")
objApp.Visible = True
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objApp = Nothing
End If
ElseIf Err.Number <> 0 Then
MsgBox Err.Number & " " & Err.Description
Set objApp = Nothing
End If
On Error GoTo 0
Set fncObjOffApp = objApp
Set objApp = Nothing
End Function