Макрос: копирование текста из Word в Excel⁠⁠

Наверное поздновато пишу. Но тем не менее. Решается это все очень успешно с помощью надстройки power query (в эксель выше 2013 установлена по умолчанию). Ее освоение, на мой взгляд, проще чем освоение макросов. Основной алгоритм с ее использованием предполагаю: подключение к нужной папке, фильтрация нужных файлов, извлечение данных из них, и полследующее усечение по поиску в тексте. Соответственно на выходе само собой соберется в обновляемую таблицу

сайт с фрилансерами в помощь. Увы, бесплатный сыр только в мышеловке.

Примерно как-то так:

Sub files_1()

Dim wbk As Workbook

Dim texttofind As String

Set wbk = ThisWorkbook

texttofind = "мыла" 'Текст для поиска в файле

pathtofile = "d:\downloads\" 'Путь к папке с фалами

wildcard = "dasff*.doc*" 'имя файла для поиска

strfile = Dir(pathtofile & wildcard)

Do While Len(strfile) > 0

t = word_to_excel(CStr(pathtofile & strfile), texttofind)

strfile = Dir

wbk.Activate

Range("a1") = t 'Переносим найденный текст в ячейку А1

Loop

wbk.Save

End Sub

Function word_to_excel(FilePath As String, texttofind As String)

Dim oWord As Word.Application

Dim WordNotOpen As Boolean

Dim oDoc As Word.Document

Dim oTbl As Word.Table

Dim fd As Office.FileDialog

Dim documenttext, firstterm, secondterm As String

Dim tabl_1 As String

Dim dottofind As String

On Error Resume Next

dottofind = "."

' Get or start Word

Set oWord = GetObject(Class:="Word.Application")

If Err Then

Set oWord = New Word.Application

WordNotOpen = True

End If

oWord.Visible = True

' Open document

Set oDoc = oWord.Documents.Open(Filename:=FilePath)

Debug.Print (oWord.ActiveDocument.ActiveWindow.View.ReadingLayout)

If oWord.ActiveDocument.ActiveWindow.View.ReadingLayout Then ActiveDocument.ActiveWindow.View.ReadingLayout = False

Set myrange = oWord.ActiveDocument.Range

documenttext = myrange.Text

midposition = InStr(1, documenttext, texttofind, vbTextCompare)

lastposition = InStr(midposition, documenttext, dottofind, vbTextCompare)

left_documenttext = Left(documenttext, lastposition)

textlength = InStr(2, StrReverse(left_documenttext), dottofind, vbTextCompare) - 1

foundtext = Trim(Mid(documenttext, lastposition - textlength + 1, textlength))

word_to_excel = foundtext

'Debug.Print (data_doc)

Exit_Handler:

On Error Resume Next

oDoc.Close SaveChanges:=False

If WordNotOpen Then

oWord.Quit

End If

'Release object references

Set oTbl = Nothing

Set oDoc = Nothing

Set oWord = Nothing

Application.ScreenUpdating = True

oWord.Quit

Application.Wait Now + #12:00:05 AM#

Exit Function

Err_Handler:

MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number

Resume Exit_Handler

End Function