Sub FromWordToExcel()
Dim oWD As Object, oDoc As Object
Dim strT As String, i As Long, j As Byte, strA() As String, strB() As String
Dim WS As Worksheet, k As Byte, l As Long

Set oWD = CreateObject("Word.Application")
Set oDoc = oWD.Documents.Open _
    ("C:\...Путь...\Export.doc")
strT = oDoc.Content
Do While InStr(strT, Chr( 11 ) & Chr( 11 )) >  0 
    strT = Replace(strT, Chr( 11 ) & Chr( 11 ), Chr( 11 ))
Loop
oWD.Quit
Set oWD = Nothing: Set oDoc = Nothing
strA = Split(strT, Chr( 11 ))
Application.ScreenUpdating = False
For k =  1  To (UBound(strA) +  1 ) \ Application.Rows.Count +  1 
    l =  1 
    With ThisWorkbook.Worksheets(k)
        For i =  0  To UBound(strA)
            strB = Split(Replace(strA(i), vbCr, ""))
            For j =  0  To UBound(strB)
                .Cells(l, j +  1 ) = strB(j)
            Next j
            l = l +  1 
        Next i
    End With
Next k
Application.ScreenUpdating = True
End Sub

oWD.Quit
Set oWD = Nothing: Set oDoc = Nothing ' "рокировка" с последующим циклом

Do While InStr(strT, Chr( 11 ) & Chr( 11 )) >  0 
    strT = Replace(strT, Chr( 11 ) & Chr( 11 ), Chr( 11 ))
Loop
strA = Split(strT, Chr( 11 )): strT = "" 'очищение ненужной более переменной

Sub FromWordToExcel()
Dim oWD As Object, oDoc As Object
Dim strT As String, i As Long, j As Integer, strA() As String, strB() As String
Dim WS As Worksheet, k As Byte, l As Long

Set oWD = CreateObject("Word.Application")
Set oDoc = oWD.Documents.Open _
    ("C:\... Путь ...\Export.doc")

Application.DisplayAlerts = False
strT = oDoc.Content
Application.DisplayAlerts = True

oWD.Quit
Set oWD = Nothing: Set oDoc = Nothing

strT = Replace(strT, Chr( 10 ), Chr( 13 ))
strT = Replace(strT, Chr( 11 ), Chr( 13 ))
Do While InStr(strT, Chr( 13 ) & Chr( 13 )) >  0 
    strT = Replace(strT, Chr( 13 ) & Chr( 13 ), Chr( 13 ))
Loop

strA = Split(strT, Chr( 13 )): strT = ""

Application.ScreenUpdating = False
For k =  1  To (UBound(strA) +  1 ) \ Application.Rows.Count +  1 
    l =  1 
    With ThisWorkbook.Worksheets(k)
        For i = i + l -  1  To UBound(strA)
            strB = Split(strA(i))
            For j =  0  To UBound(strB)
                .Cells(l, j +  1 ) = strB(j)
            Next j
            l = l +  1 
            If l = .Rows.Count +  1  Then
                i = i +  1 
                Exit For
            End If
        Next i
    End With
Next k
Application.ScreenUpdating = True
End Sub

Sub FromWordToExcel2()
Dim oWD As New Word.Application, oDoc As Word.Document 'раннее связывание
Dim fso As New Scripting.FileSystemObject, oFile As Scripting.File 'раннее связывание
Dim strT As String, oTS1 As Scripting.TextStream, oTS2 As Scripting.TextStream 'раннее связывание

'Dim oWD As Object, oDoc As Object
'Dim fso As Object, oFile As Object
'Dim strT As String, oTS1 As Object, oTS2 As Object
'Const wdFormatText As Long = 2, ForWriting As Byte = 2

Dim lngLnsCount As Long, bytWSCount As Byte, strFIlesPath As String
Dim oTmpWB As Workbook, stb

'Set oWD = CreateObject("Word.Application")
'Set fso = CreateObject("Scripting.FileSystemObject")

bytWSCount =  1 
Set oDoc = oWD.Documents.Open _
    ("C:\... Путь ...\Export.doc"\Export2.doc")
oDoc.SaveAs oDoc.Path & "\Export2.txt", wdFormatText
Set oFile = fso.GetFile(oDoc.FullName)
oWD.Quit: Set oDoc = Nothing: Set oWD = Nothing
Set oTS1 = fso.OpenTextFile(oFile)
strFIlesPath = Left(oFile.Path, InStrRev(oFile.Path, "\"))
Set oTS2 = fso.CreateTextFile(strFIlesPath & "Tmp.txt", ForWriting, True)
Application.EnableEvents = False
Application.ScreenUpdating = False
Do Until oTS1.AtEndOfStream
    strT = oTS1.ReadLine
    If Len(strT) > 0 Then
        lngLnsCount = lngLnsCount + 1
        oTS2.WriteLine strT
    End If
    If lngLnsCount = Application.Rows.Count Or oTS1.AtEndOfStream Then
        oTS2.Close
        Workbooks.OpenText Filename:=strFIlesPath & "Tmp.txt", Origin:=1251, _
            StartRow:=1, DataType:=xlDelimited, Space:=True, FieldInfo:=Array(Array(1, 1), _
            Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
        Set oTmpWB = Workbooks("Tmp.txt")
        oTmpWB.Worksheets(1).Cells.Copy ThisWorkbook.Worksheets(bytWSCount).Cells
        oTmpWB.Close
        bytWSCount = bytWSCount + 1
        lngLnsCount = 0
        Set oTS2 = fso.CreateTextFile(strFIlesPath & "Tmp.txt")
    End If
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
oTS1.Close: oTS2.Close
Kill oFile: Kill strFIlesPath & "Tmp.txt"
End Sub

', TrailingMinusNumbers:=True 'это на  2000  не пошло

Set objDialog = CreateObject("UserAccounts.CommonDialog")
objDialog.Filter = "Doc Files|*.doc"
objDialog.InitialDir = "C:\"
intResult = objDialog.ShowOpen
 If intResult =  0  Then
    Exit Sub
Else
    toFile = objDialog.Filename
End If
DoEvents

Sub FromWordToExcel3()
Dim oWD As New Word.Application, oDoc As Word.Document
Dim fso As New Scripting.FileSystemObject, oFile As Scripting.File, _
    strT As String, oTS1 As Scripting.TextStream, oTS2 As Scripting.TextStream
Dim cnTXT As New ADODB.Connection, rs As New ADODB.Recordset
Dim lngLnsCount As Long, bytWSIndx As Byte, strFIlesPath As String
Dim oTmpWB As Workbook, strDate As String, lngRowCnt As Long, lngRCrs As Long

Set oDoc = oWD.Documents.Open _
    ("C:\...\Export2.doc")
oDoc.SaveAs oDoc.Path & "\Export2.txt", wdFormatText
Set oFile = fso.GetFile(oDoc.FullName)
oWD.Quit: Set oDoc = Nothing: Set oWD = Nothing

Set oTS1 = fso.OpenTextFile(oFile)
strFIlesPath = Left(oFile.Path, InStrRev(oFile.Path, "\"))
Set oTS2 = fso.CreateTextFile(strFIlesPath & "Tmp.txt", ForWriting)

Do Until oTS1.AtEndOfStream
    strT = oTS1.ReadLine
    If Len(strT) >  0  Then
        If IsDate(strT) Then
            lngLnsCount = lngLnsCount +  1 
            strDate = lngLnsCount & " " & strT & " "
        Else
            oTS2.WriteLine Replace(strDate & strT, " ", ";")
            strDate = "": strT = ""
        End If
    End If
Loop
oTS1.Close: oTS2.Close
Set oTS1 = Nothing: Set oTS2 = Nothing

cnTXT.Mode = adModeRead
cnTXT.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data SoulngRCrse=" & strFIlesPath & ";Extended Properties='text;HDR=NO;FMT=Delimited'"
rs.CursorType = adOpenStatic
lngRowCnt = Application.Rows.Count
Application.EnableEvents = False
Application.ScreenUpdating = False
For bytWSIndx =  1  To lngLnsCount / lngRowCnt +  1 
    Set rs = cnTXT.Execute("SELECT F2,F3,F4,F5 FROM Tmp.txt WHERE F1 BETWEEN " & _
        lngRCrs +  1  & " AND " & lngRCrs + lngRowCnt)
    lngRCrs = lngRCrs + lngRowCnt
    With ThisWorkbook.Worksheets(bytWSIndx)
        .Cells( 1 ,  1 ).CopyFromRecordset rs
        .Columns( 1 ).NumberFormat = "dd.mm.yy"
    End With
Next
cnTXT.Close
Set cnTXT = Nothing: Set rs = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Kill oFile: Kill strFIlesPath & "Tmp.txt"
End Sub