Оптимизировать макрос в Excel по внесению изменений в файлы word

[Snekich]

Написал макрос в файле Excel, суть которого в следующем:

Открываем файл Word c именем, указанным в столбце 1.
Искомый текст, указанный в столбце 3, заменяем на текст, указанный в столбце 4 с сохранением стилей и форматирования. (
Закрываем файл с сохранением.
Открываем второй файл и повторяем все операции.

Нюанс в том, что файлов много (около 20) и в каждом файле необходимо произвести много замен (по 30 в каждом).

Итого мой код работает путем полного перебора всех вариантов т.е.
файл word откроется, изменится и закроется в сумме около 600 раз...

Что бы один и тот же файл не открывать заново для каждого из изменений, строку

objDocument.Content.Find.Execute LettersTextTemplate, False, False, False, False, False, True, 1, False, LettersTextFinal, 2

делал внутри оператора For i2 = v2 To lLastRow2 (там же присваивались переменные LettersTextTemplate, LettersTextFinal), но не смог заставить код работать....

По возможности, прошу помочь оптимизировать код, что бы при выполнении не требовалось около 600 раз открыть/закрыть word.
Но нужно именно замена текста в файле, вставка текста по меткам не подойдет. Буду очень благодарен за помощь.

Public FullNameLetter, LettersTextTemplate, LettersTextFinal As String
Sub Letters_caption()
'поочередно открываем файлы и вносим в них изменения
Application.ScreenUpdating = False 'выключаем показ действий
Dim ActiveWorkbook_Path As String
Dim Folder_Excel As String
Dim i As Long, lLastRow As Long
Dim i2 As Long
Dim lLastRow2 As Long
Dim m As Integer
Dim v As Integer
Dim v2 As Integer
Dim ind As Integer
Dim column_number_letters_text_template As Integer
Dim column_number_letters_text_Final As Integer
ActiveWorkbook_Path = ActiveWorkbook.Path 'папка с рабочим файлом
Folder_Excel = "C:\test\" 'определяем путь файла
Sheets("РД").Select
m = 1 'номер столбца с перечнем файлов
lLastRow = Cells(Rows.Count, m).End(xlUp).Row 'последняя заполненная cтрока в столбце column_number
n = 2 'номер столбца с отметкой о необходимости вносить изменения в файл
v = 1 'номер строки с которой начинается перечень имен файлов
column_number_letters_text_template = 3 'номер столбца с исходным текстом в файлах шаблонах
column_number_letters_text_Final = 4 'номер столбца с итоговым текстом в итоговых файлах
lLastRow2 = Cells(Rows.Count, column_number_letters_text_Final).End(xlUp).Row 'последняя заполнена
я строка в столбце с шаблонами текста
v2 = 1 'номер строки с которой начинается перечень шаблонов текста
n2 = 5 'номер столбца с отметкой о необходимости менять текст из данной строки
For i = v To lLastRow 'построчно перебираем все имена файлов
Sheets("Письма").Select 'вероятно не обязательно, но на всякий случай
If Cells(i, n).Value = "+" Then ' изменяем только файлы отмеченные знаком "+" в столбце n
FullNameLetter = ActiveWorkbook_Path & Folder_Excel & Cells(i, m) 'записываем в глобальную переменную полный путь файла и имя с расширением
For i2 = v2 To lLastRow2 'построчно перебираем все ячейки с искомым текстом в файлах word
'Присваиваем значения ячеек переменным
If Cells(i2, n2).Value = "+" Then ' пропускаем строки с шаблонами текста, которые не нужны
LettersTextTemplate = Cells(i2, column_number_letters_text_template).Value '- записываем искомый(шаблонный) текст в глобальную переменную
LettersTextFinal = Cells(i2, column_number_letters_text_Final).Value '- записываем итоговый текст в
глобальную переменную
Application.Run "subroutine_letters" 'запускаем макрос по поиску и замене текста в файлах word
End If
Next i2
End If
Next i
Application.ScreenUpdating = True 'включаем показ действий
End Sub

Private Sub subroutine_letters()
On Error Resume Next ' пропускам ошибки. на случай, если не окажется нужного файла
Set objWord = CreateObject("Word.Application")
If Err.Number Then
MsgBox "Не получилось открыть файл Word."
Exit Sub
End If
pt = FullNameLetter
Set objDocument = objWord.Documents.Open(Filename:=pt) ' здесь мы получили исходный документ
objDocument.Content.Find.Execute LettersTextTemplate, False, False, False, False, False, True, 1, False, LettersTextFinal, 2 ' замена искомого(шаблонного) текста на итоговый без изменения стилей
objWord.Visible = True 'отображаем документ
objDocument.Close True ' закрываем файл с сохранением
objWord.Quit 'закрываем оболочку word, в противном случае остается куча пустых открытых окон word
Set myRange = Nothing
Set objDocument = Nothing
Set objWord = Nothing
End Sub

[Hugo121]

Как вариант - передавать в Sub subroutine_letters как параметр массив (или два) с словами для замены. И после открытия документа в цикле по массивам делать поиск-замену.

[doober]

Это точно ересь.

    ActiveWorkbook_Path = ActiveWorkbook.Path    'папка с рабочим файлом
    Folder_Excel = "C:\test\"    'определяем путь файла
    FullNameLetter = ActiveWorkbook_Path & Folder_Excel & Cells(i, m)    'записываем в глобальную переменную полный путь файла и имя с расширением

По идее должно работать, только с путями разберитесь

Sub Letters_caption()

 Dim FullNameLetter   As String, LettersTextTemplate  As String, LettersTextFinal As String
'поочередно открываем файлы и вносим в них изменения
    Application.ScreenUpdating = False    'выключаем показ действий
    Dim ActiveWorkbook_Path As String
    Dim Folder_Excel As String
    Dim i As Long, lLastRow As Long
    Dim i2 As Long
    Dim lLastRow2 As Long
    Dim m As Integer
    Dim v As Integer
    Dim v2 As Integer
    Dim ind As Integer
    Dim column_number_letters_text_template As Integer
    Dim column_number_letters_text_Final As Integer
    ActiveWorkbook_Path = ActiveWorkbook.Path    'папка с рабочим файлом
    Folder_Excel = "C:\test\"    'определяем путь файла
    Sheets("РД").Select
    m = 1    'номер столбца с перечнем файлов
    lLastRow = Cells(Rows.Count, m).End(xlUp).Row    'последняя заполненная cтрока в столбце column_number
    n = 2    'номер столбца с отметкой о необходимости вносить изменения в файл
    v = 1    'номер строки с которой начинается перечень имен файлов
    column_number_letters_text_template = 3    'номер столбца с исходным текстом в файлах шаблонах
    column_number_letters_text_Final = 4    'номер столбца с итоговым текстом в итоговых файлах
    lLastRow2 = Cells(Rows.Count, column_number_letters_text_Final).End(xlUp).Row    'последняя заполнена  я строка в столбце с шаблонами текста
    v2 = 1    'номер строки с которой начинается перечень шаблонов текста
    n2 = 5    'номер столбца с отметкой о необходимости менять текст из данной строки

    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True    'отображаем документ

    For i = v To lLastRow    'построчно перебираем все имена файлов

        Sheets("Письма").Select    'вероятно не обязательно, но на всякий случай
        If Cells(i, n).Value = "+" Then    ' изменяем только файлы отмеченные знаком "+" в столбце n
            FullNameLetter = ActiveWorkbook_Path & Folder_Excel & Cells(i, m)    'записываем в глобальную переменную полный путь файла и имя с расширением
            Set objDocument = objWord.Documents.Open(Filename:=FullNameLetter)    ' здесь мы получили исходный документ

            For i2 = v2 To lLastRow2    'построчно перебираем все ячейки с искомым текстом в файлах word
                'Присваиваем значения ячеек переменным
                If Cells(i2, n2).Value = "+" Then    ' пропускаем строки с шаблонами текста, которые не нужны
                    LettersTextTemplate = Cells(i2, column_number_letters_text_template).Value    '- записываем искомый(шаблонный) текст в глобальную переменную
                    LettersTextFinal = Cells(i2, column_number_letters_text_Final).Value    '- записываем итоговый текст в
               objDocument.Content.Find.Execute LettersTextTemplate, False, False, False, False, False, True, 1, False, LettersTextFinal, 2    ' замена искомого(шаблонного) текста на итоговый без изменения стилей

                End If
            Next i2

            objDocument.Close True    ' закрываем файл с сохранением
            Set objDocument = Nothing

        End If
    Next i
        objWord.Quit    'закрываем оболочку word, в противном случае остается куча пустых открытых окон word
    Set objWord = Nothing
    
    Application.ScreenUpdating = True    'включаем показ действий
End Sub

[Snekich]

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

Это точно ересь.

    ActiveWorkbook_Path = ActiveWorkbook.Path    'папка с рабочим файлом
    Folder_Excel = "C:\test\"    'определяем путь файла
    FullNameLetter = ActiveWorkbook_Path & Folder_Excel & Cells(i, m)    'записываем в глобальную переменную полный путь файла и имя с расширением

По идее должно работать, только с путями разберитесь

Да, в этом моменте некорректно задан путь файла, ошибся при сокращении кода для форума.

Sub Letters_caption()

 Dim FullNameLetter   As String, LettersTextTemplate  As String, LettersTextFinal As String
'поочередно открываем файлы и вносим в них изменения
    Application.ScreenUpdating = False    'выключаем показ действий
    Dim ActiveWorkbook_Path As String
    Dim Folder_Excel As String
    Dim i As Long, lLastRow As Long
    Dim i2 As Long
    Dim lLastRow2 As Long
    Dim m As Integer
    Dim v As Integer
    Dim v2 As Integer
    Dim ind As Integer
    Dim column_number_letters_text_template As Integer
    Dim column_number_letters_text_Final As Integer
    ActiveWorkbook_Path = ActiveWorkbook.Path    'папка с рабочим файлом
    Folder_Excel = "C:\test\"    'определяем путь файла
    Sheets("РД").Select
    m = 1    'номер столбца с перечнем файлов
    lLastRow = Cells(Rows.Count, m).End(xlUp).Row    'последняя заполненная cтрока в столбце column_number
    n = 2    'номер столбца с отметкой о необходимости вносить изменения в файл
    v = 1    'номер строки с которой начинается перечень имен файлов
    column_number_letters_text_template = 3    'номер столбца с исходным текстом в файлах шаблонах
    column_number_letters_text_Final = 4    'номер столбца с итоговым текстом в итоговых файлах
    lLastRow2 = Cells(Rows.Count, column_number_letters_text_Final).End(xlUp).Row    'последняя заполнена  я строка в столбце с шаблонами текста
    v2 = 1    'номер строки с которой начинается перечень шаблонов текста
    n2 = 5    'номер столбца с отметкой о необходимости менять текст из данной строки

    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True    'отображаем документ

    For i = v To lLastRow    'построчно перебираем все имена файлов

        Sheets("Письма").Select    'вероятно не обязательно, но на всякий случай
        If Cells(i, n).Value = "+" Then    ' изменяем только файлы отмеченные знаком "+" в столбце n
            FullNameLetter = ActiveWorkbook_Path & Folder_Excel & Cells(i, m)    'записываем в глобальную переменную полный путь файла и имя с расширением
            Set objDocument = objWord.Documents.Open(Filename:=FullNameLetter)    ' здесь мы получили исходный документ

            For i2 = v2 To lLastRow2    'построчно перебираем все ячейки с искомым текстом в файлах word
                'Присваиваем значения ячеек переменным
                If Cells(i2, n2).Value = "+" Then    ' пропускаем строки с шаблонами текста, которые не нужны
                    LettersTextTemplate = Cells(i2, column_number_letters_text_template).Value    '- записываем искомый(шаблонный) текст в глобальную переменную
                    LettersTextFinal = Cells(i2, column_number_letters_text_Final).Value    '- записываем итоговый текст в
               objDocument.Content.Find.Execute LettersTextTemplate, False, False, False, False, False, True, 1, False, LettersTextFinal, 2    ' замена искомого(шаблонного) текста на итоговый без изменения стилей

                End If
            Next i2

            objDocument.Close True    ' закрываем файл с сохранением
            Set objDocument = Nothing

        End If
    Next i
        objWord.Quit    'закрываем оболочку word, в противном случае остается куча пустых открытых окон word
    Set objWord = Nothing
    
    Application.ScreenUpdating = True    'включаем показ действий
End Sub

Огромнейшее спасибо!
Я именно этого и хотел добиться, но опыта у меня не хватило, что бы сделать это без ошибок.
Внес изменения в свой исходный код, работает теперь как надо!