поиск текста в файлах папки и запись результатов

[Пименов Александр]

Сообщение от Composter

подскажите, а можно ли чтобы VBA перебрал доковские файлы в папке, в которой хранится документ с макросом, без диалогового окна?

Можно и без окна.
Для этого нужно объявить объект FSO как FileSystemObject, для этого откройте меню Tools --> References и поставьте галочку на объекте MicrosoftScriptingRuntame, нажмите ОК
Далее можно объявлять объекты FileSystemObject

Public Sub Open_Files()
Dim FSO As FileSystemObject
Dim Fold As Folder
Dim fl As File
Dim Doc As Document ' Документ в котором делаем сборку найденного текста
Dim mDoc As Document ' Временный документ созданный при переборе документов выбранных в диалоговом окне
Dim rng As Range ' Место в документе Doc куда будем вставлять найденный текст
    Set FSO = New FileSystemObject ' Создаем новый объект FileSystemObject
    Set Doc = ActiveDocument ' Создаем документ сборки из активного документа
    Set Fold = FSO.GetFolder(Doc.Path) ' Определяем папку в которой искать файлы
    For Each fl In Fold.Files ' Перебираем файлы находящиеся в папке Fold
        If fl.Name <> Doc.Name Then ' Условие, если имя файла не равно имени документа сборки то
            Select Case FSO.GetExtensionName(fl) ' Определяем расширение файла
                Case "doc", "docx", "docm" ' Если расширение файла "doc", "docx", "docm" то
                    Set mDoc = Documents.Open(Fold.Name & "\" & fl.Name) ' Открываем временный документ для поиска текста
'----------------------------------------------------------------------------------
' Здесь добавляем код по поиску и выделению нужного текста в документе mDoc
'----------------------------------------------------------------------------------
            Selection.Copy ' Копируем нужный текст
            mDoc.Close ' Закрываем временный файл
            Doc.Activate ' Активизируем документ сборки
'----------------------------------------------------------------------------------
' Переходим в конец документа Doc
'----------------------------------------------------------------------------------
            Selection.PasteAndFormat ' Вставляем текст из буфера обмена в конец документа сборки
            End Select
        End If
    Next fl
End Sub

[Composter]

спасибо всем,кто помогал, особенно Пименову Александру.
вопрос а если скинуть этот файл на другой комп, та нуна выставлять вот это
"объявить объект FSO как FileSystemObject, для этого откройте меню Tools --> References и поставьте галочку на объекте MicrosoftScriptingRuntame, нажмите ОК"?
выкладываю получившееся

Option Explicit
Option Base 1
Dim z1 As String, z2 As String
Dim stroka_1 As String, stroka_2 As String
Private Sub poisk_teksta()
Dim myRange As Range
Dim na4_str As Long, kon_str As Long
Set myRange = ActiveDocument.Content
na4_str = InStr(1, myRange.Text, stroka_1, 1) - 1
If na4_str > 0 Then kon_str = InStr(na4_str, myRange.Text, stroka_2, 1) - 1 - na4_str
If ((na4_str < 0) Or (kon_str < 0)) Then
    z1 = ""
    z2 = ""
    Exit Sub
End If
z2 = Mid(myRange.Text, na4_str, kon_str)
z1 = Left(ActiveDocument.Name, InStr(1, ActiveDocument.Name, ".") - 1)
End Sub
Public Sub Open_Files()
Dim FSO As FileSystemObject
Dim Fold As Folder
Dim fl As File
Dim i As Long
Dim arr1() As Variant
ReDim arr1(2, 1) As Variant
i = 1
Dim Doc As Document ' Документ в котором делаем сборку найденного текста
stroka_1 = InputBox(prompt:="Введите первую строку")
stroka_2 = InputBox(prompt:="Введите вторую строку")
Dim mDoc As Document ' Временный документ созданный при переборе документов выбранных в диалоговом окне
Set FSO = New FileSystemObject ' Создаем новый объект FileSystemObject
Set Doc = ActiveDocument ' Создаем документ сборки из активного документа
Set Fold = FSO.GetFolder(Doc.Path) ' Определяем папку в которой искать файлы
For Each fl In Fold.Files ' Перебираем файлы находящиеся в папке Fold
        If fl.Name <> Doc.Name Then ' Условие, если имя файла не равно имени документа сборки то
            Select Case FSO.GetExtensionName(fl) ' Определяем расширение файла
                Case "doc", "docx", "docm" ' Если расширение файла "doc", "docx", "docm" то
                    Set mDoc = Documents.Open(Doc.Path & "\" & fl.Name) ' Открываем временный документ для поиска текста
            Call poisk_teksta
            mDoc.Close ' Закрываем временный файл
            arr1(1, i) = z1
            arr1(2, i) = z2
            i = i + 1
            ReDim Preserve arr1(2, i) As Variant
            End Select
        End If
    Next fl
Doc.Activate
Selection.EndKey Unit:=wdStory
For i = 1 To UBound(arr1, 2)
    If arr1(1, i) > "" Then
        Selection.Text = arr1(1, i) & vbTab
        Selection.EndOf
        Selection.Text = arr1(2, i) & vbNewLine
        Selection.EndOf
    End If
Next i
End Sub

[Пименов Александр]

Желательно выполнить действия Tools --> References, т.к. тогда при написании кода будут всплывать подсказки и удобнее работать. Но можно объявить FSO и как объект:

Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

Но тогда придется объекты Folder и File объявлять как Object и код со свойствами и методами набирать вручную, а для этого надо знать структуру FileSystemObject