Sub CopyWord()
Call CreateNewWord
Dim WB As Workbook
Dim WS As Worksheet
Dim wrdApp As Object
Dim WrdDoc As Object
Dim myRange
Dim myTabel
Set WB = ThisWorkbook
Set WS = WB.Worksheets(1) '"Sheet1" or any Name "Sheet_Name"
Set wrdApp = CreateObject("Word.Application")
Path = Environ("USERPROFILE") & "\" & "Desktop"
WrdPath = Path & "\" & "wrd.docx"
Set WrdDoc = wrdApp.documents.Open(WrdPath)
wrdApp.Visible = True
''''''''''''word'''''''''''''
With WrdDoc
.Content.WholeStory
.Content.Copy
End With
''''''''''''Excel'''''''''''''
With WS
.Cells(15, 1).Select
.Paste
End With
WrdDoc.Close SaveChanges:=wdDoNotSaveChanges
wrdApp.Quit
Set WrdDoc = Nothing
Set wrdApp = Nothing
End Sub
Sub CreateNewWord()
Dim WB As Workbook
Dim WS As Worksheet
Dim wrdApp As Object
Dim WrdDoc As Object
Dim myRange
Dim myTabel
Set WB = ThisWorkbook
Set WS = WB.Worksheets(1) '"Sheet1" or any Name "Sheet_Name"
Dim WrdPath As String
Path = Environ("USERPROFILE") & "\" & "Desktop"
WrdPath = Path & "\" & "wrd.docx"
On Error Resume Next
If Len(Dir$(WrdPath)) > 0 Then Kill WrdPath
On Error GoTo 0
Set wrdApp = CreateObject("Word.Application")
Set WrdDoc = wrdApp.documents.Add
wrdApp.Visible = True
WrdDoc.SaveAs WrdPath
'do what
'add table
Set myRange = WrdDoc.Range(0, 0)
'cop from excel
WS.Range("A1:D5").Copy
wrdApp.Selection.Paste 'Special Link:=False, DataType:=wdPasteEnhancedMetafile, _
Placement:=wdInLine, DisplayAsIcon:=False
'or wrting text
wrdApp.Selection.TypeParagraph
wrdApp.Selection.Range.InsertAfter Text:=vbNewLine & vbNewLine & "MR EXCEL" & vbNewLine & "Thanks"
Set myTabel = WrdDoc.Tables.Add(Range:=myRange, NumRows:=3, NumColumns:=4)
myTabel.Borders.Enable = True
myTabel.Cell(1, 1).Range.Text = "Hi"
myTabel.Cell(1, 2).Range.Text = "Good"
myTabel.Cell(2, 1).Range.Text = "Very Good"
wrdApp.Selection.TypeParagraph
wrdApp.Activate
WrdDoc.Close True
wrdApp.Quit
Set WrdDoc = Nothing
Set wrdApp = Nothing
End Sub