Sub main()
Dim wdApp As Object
Dim wdDoc As Object

HomeDir$ = ThisWorkbook.Path
Set wdApp = CreateObject("Word.Application")

I% = 8
Do
If Cells(I%, 1).Value = "" Then Exit Do
If Cells(I%, 1).Value <> "" Then

FIO$ = Cells(I%, 1).Text
DOLG$ = Cells(I%, 2).Text
SP$ = Cells(I%, 3).Text
KSH$ = Cells(I%, 4).Text
Data$ = Cells(I%, 10).Text
' Добавьте недостающие переменные (если нужно)
PROG$ = Cells(I%, 5).Text ' Пример для столбца 5
CHAS$ = Cells(I%, 6).Text ' Пример для столбца 6
PRICHINA$ = Cells(I%, 7).Text
DOLCOT$ = Cells(I%, 8).Text
DATARAB$ = Cells(I%, 9).Text

' Копируем шаблон
FileCopy HomeDir$ & "\Шаблоны\" & KSH$ & ".docx", HomeDir$ & "\" & FIO$ & " " & SP$ & ".doc"
Set wdDoc = wdApp.Documents.Open(HomeDir$ & "\" & FIO$ & " " & SP$ & ".doc")

' Замена меток (оптимизировано - убраны дубликаты)
With wdDoc.Range.Find
.Execute FindText:="&fio", ReplaceWith:=FIO$
.Execute FindText:="&dolg", ReplaceWith:=DOLG$
.Execute FindText:="&sp", ReplaceWith:=SP$
.Execute FindText:="&prog", ReplaceWith:=PROG$
.Execute FindText:="&chas", ReplaceWith:=CHAS$
.Execute FindText:="&chass", ReplaceWith:=CHAS$
.Execute FindText:="&prichina", ReplaceWith:=PRICHINA$
.Execute FindText:="&Data", ReplaceWith:=Data$
.Execute FindText:="&FIOSOT", ReplaceWith:=Application.UserName
.Execute FindText:="&DOLCOT", ReplaceWith:=DOLCOT$
.Execute FindText:="&DATARAB", ReplaceWith:=DATARAB$
End With

' Сохраняем как PDF и закрываем
pdfPath$ = HomeDir$ & "\" & FIO$ & " " & SP$ & ".pdf"
wdDoc.SaveAs2 FileName:=pdfPath$, FileFormat:=17 ' 17 = wdFormatPDF
wdDoc.Close

' Удаляем временный Word-файл
Kill HomeDir$ & "\" & FIO$ & " " & SP$ & ".doc"
End If

I% = I% + 1
Loop

wdApp.Quit
MsgBox "Готово! PDF-файлы созданы."
End Sub

' Объявление Windows API-функции для создания пауз
#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Sub GenerateDocuments()
    ' Объявление переменных
    Dim wdApp As Object    ' Объект приложения Word
    Dim wdDoc As Object    ' Объект документа Word
    Dim HomeDir As String  ' Путь к рабочей папке
    Dim I As Long          ' Счетчик строк (Long вместо Integer для больших объемов)
    
    ' Настройка обработки ошибок
    On Error GoTo ErrorHandler
    
    ' Определение рабочей директории
    HomeDir = ThisWorkbook.Path  ' Путь к папке с текущим Excel-файлом
    
    ' Создание экземпляра Word
    Set wdApp = CreateObject("Word.Application")  ' Создаем невидимый объект Word
    wdApp.Visible = False        ' Скрываем интерфейс Word
    wdApp.ScreenUpdating = False ' Отключаем обновление экрана (ускоряет работу)
    
    ' Основной цикл обработки данных
    I = 8  ' Начинаем с 8-й строки (предполагается, что заголовки в 1-7)
    Do While Cells(I, 1).Value <> ""  ' Цикл пока есть данные в столбце A
        
        ' Чтение данных из таблицы Excel
        FIO = Cells(I, 1).Text    ' ФИО из столбца A
        DOLG = Cells(I, 2).Text   ' Должность из столбца B
        SP = Cells(I, 3).Text     ' Доп. параметр из столбца C
        KSH = Cells(I, 4).Text    ' Имя шаблона из столбца D
        Data = Cells(I, 10).Text  ' Дата из столбца J
        
        ' Работа с файлами
        Dim tempDocPath As String
        tempDocPath = HomeDir & "\" & FIO & " " & SP & ".doc"  ' Генерация имени временного файла
        
        ' Копирование шаблона
        FileCopy _
            Source:=HomeDir & "\Шаблоны\" & KSH & ".docx", _
            Destination:=tempDocPath  ' Создаем копию шаблона
        
        ' Открытие документа в Word
        Set wdDoc = wdApp.Documents.Open(tempDocPath)  ' Загружаем временный файл
        
        ' Поиск и замена меток в документе
        With wdDoc.Range.Find
            ' Параметры поиска:
            .MatchCase = False     ' Игнорировать регистр
            .MatchWholeWord = False ' Не требовать полного совпадения слова
            
            ' Замена меток (цифра 2 в конце = Replace:=wdReplaceAll)
            .Execute "&fio", , , , , , , , , FIO, 2   ' Замена всех вхождений &fio
            .Execute "&dolg", , , , , , , , , DOLG, 2 ' Замена всех &dolg
            .Execute "&sp", , , , , , , , , SP, 2     ' Замена всех &sp
            .Execute "&Data", , , , , , , , , Data, 2 ' Замена всех &Data
        End With
        
        ' Экспорт в PDF
        wdDoc.ExportAsFixedFormat _
            OutputFileName:=HomeDir & "\" & FIO & " " & SP & ".pdf", _
            ExportFormat:=17  ' 17 = константа wdExportFormatPDF
        
        ' Закрытие документа
        wdDoc.Close SaveChanges:=False  ' Закрываем без сохранения изменений
        Set wdDoc = Nothing  ' Освобождаем память
        
        ' Удаление временного файла
        Kill tempDocPath  ' Удаляем копию шаблона
        
        ' Управление производительностью
        If I Mod 20 = 0 Then  ' Каждые 20 документов
            DoEvents          ' Разрешаем обработку других событий
            Sleep 500         ' Пауза 500 мс (0.5 секунды)
            Application.StatusBar = "Обработано: " & I - 7  ' Вывод прогресса
        End If
        
        I = I + 1  ' Следующая строка
    Loop
    
Cleanup:  ' Блок очистки
    If Not wdApp Is Nothing Then
        wdApp.Quit      ' Закрываем Word
        Set wdApp = Nothing  ' Освобождаем память
    End If
    Application.StatusBar = False  ' Сбрасываем статусную строку
    
    MsgBox "Обработано документов: " & I - 8, vbInformation
    Exit Sub
    
ErrorHandler:  ' Обработка ошибок
    MsgBox "Ошибка в строке " & I & ": " & Err.Description, vbCritical
    Resume Cleanup  ' Переход к блоку очистки
End Sub