Try the following. It works with the data as supplied, but I note that the existing data in your workbook are quite different. You could check the file path & name, too.
Sub GetData()
Application.ScreenUpdating = False
'Note: A reference to the Word library must be set, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim xlSht As Worksheet, lRow As Long, r As Long, i As Long
Dim StrDocNm As String, StrPart As String, StrOrder As String
StrDocNm = "C:\Users\" & Environ("UserName") & "\Documents\Downloads\asla\MR713_DYNACAST_S08 (1).docx"
If Dir(StrDocNm) = "" Then Exit Sub
Set xlSht = ThisWorkbook.Worksheets("PurchaseOrder")
lRow = xlSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).row + 1: r = lRow
Set wdDoc = wdApp.Documents.Open(Filename:=StrDocNm, ReadOnly:=True, AddToRecentFiles:=False)
wdApp.Visible = True
With wdDoc
With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
.Text = "*(PART)"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceOne
.Text = "(PART [A-Z0-9]@-[0-9]{1,})*DATE*^13"
.Replacement.Text = "\1^p"
.Execute Replace:=wdReplaceAll
.Text = "^13( [0-9]{1,2}/[0-9]{2}/[0-9]{2}[!^13]@[0-9]{1,}>)[!^13]{1,}"
.Replacement.Text = "^p\1"
.Execute Replace:=wdReplaceAll
.Text = "[-]{7}CD*^13*PAGE*([-]@^13)"
.Replacement.Text = "\1"
.Execute Replace:=wdReplaceAll
.Text = "--DATE*^13*[-]@^13{1,}"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
.Text = "^13 ([0-9]{1,2}/[0-9]{2}/[0-9]{2})"
.Replacement.Text = "^p\1"
.Text = "^13 ([0-9]{1,2}/[0-9]{2}/[0-9]{2})[!^13]@([0-9]{1,}>)"
.Replacement.Text = "^p\1^t\2"
.Execute Replace:=wdReplaceAll
.Forward = False
.Text = "([0-9]{1,2}/[0-9]{2}/[0-9]{2}^t[0-9]{1,}>)*DELIVERY*[ ]{1,}([A-Z0-9\-]{8,12})"
.Replacement.Text = "\1^p\2"
.Execute Replace:=wdReplaceOne
End With
For i = 1 To .Paragraphs.Count
If Trim(.Paragraphs(i).Range.Words.First) = "PART" Then
StrPart = Split(Split(.Paragraphs(i).Range.Text, " ")(1), vbCr)(0)
ElseIf InStr(.Paragraphs(i).Range.Text, vbTab) > 0 Then
xlSht.Range("D" & r).Value = Split(.Paragraphs(i).Range.Text, vbTab)(0)
xlSht.Range("E" & r).Value = StrPart
xlSht.Range("F" & r).Value = Split(Split(.Paragraphs(i).Range.Text, vbTab)(1), vbCr)(0)
r = r + 1
ElseIf InStr(.Paragraphs(i).Range.Text, vbTab) = 0 Then
If Len(.Paragraphs(i).Range.Text) > 1 Then
StrOrder = Split(.Paragraphs(i).Range.Text, vbCr)(0)
End If
End If
Next
For i = lRow To r - 1
xlSht.Range("B" & i).Value = StrOrder
xlSht.Range("A" & i).Value = xlSht.Range("A" & i - 1).Value + 1
Next
.Close SaveChanges:=False
End With
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlSht = Nothing
Application.ScreenUpdating = True
End Sub