Extract data from Word to Excel

[janicefool]

Would like to ask if there's a way to extract data from MS Word to Excel?

I have a WORD file with the format set. I want to extract the data from Word to Excel for every new Word doc.

My daily tasks requires me to create new word doc in that format and then transfer the information from that word document into EXCEL. Is there a way to do it?

 

[Dossfm0q]

as example

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