Sub Test()
    Call CopyToWord(Sheet1.Range("A1:D10"))
End Sub
 
Sub CopyToWord(rngCopy As Range)
    Dim appWD           As Object 'Word.Application
    Dim arr()
    Dim lngRow          As Long
    Dim lngCol          As Long
 
    arr() = rngCopy
 
    Set appWD = CreateObject("Word.Application.8")
    Application.ScreenUpdating = False
 
    appWD.Documents.Add
 
    For lngRow = 1 To UBound(arr(), 1)
        For lngCol = 1 To UBound(arr(), 2)
            If lngCol = UBound(arr(), 2) Then
                appWD.Selection.typetext Text:=CStr(arr(lngRow, lngCol))
            Else
                appWD.Selection.typetext Text:=CStr(arr(lngRow, lngCol)) & vbTab
            End If
        Next lngCol
        If lngRow <> UBound(arr(), 1) Then
            appWD.Selection.TypeParagraph
        End If
    Next lngRow
 
    appWD.Selection.WholeStory
    appWD.Selection.ConvertToTable Separator:=1, NumColumns:=UBound(arr(), 2), _
        NumRows:=UBound(arr(), 1), AutoFitBehavior:=0
    With appWD.Selection.Tables(1)
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = True
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = True
    End With
    appWD.Selection.EndKey Unit:=6
 
    appWD.Visible = True
 
    Set appWD = Nothing
    Application.ScreenUpdating = True
End Sub