Sub AKT()
    Dim wdApp As Object
    Dim wdDoc As Object
 
HomeDir$ = ThisWorkbook.Path
Set wdApp = CreateObject("Word.Application")
    i% = 3
Do
    If Cells(i%, 1).Value = "" Then Exit Do
    If Cells(i%, 1).Value <> "" Then
    
Название$ = Cells(i%, 1).Value
Производитель$ = Cells(i%, 2).Value
Центр$ = Cells(i%, 3).Value
AG$ = Cells(i%, 4).Value
AT$ = Cells(i%, 5).Value

DataC$ = Date

FileCopy HomeDir$ + "\AKT.doc", HomeDir$ & "\" & "Готовые документы" + "\Акт " + Название$ + "_" + Производитель$ + "_" + DataC$ + ".doc"
Set wdDoc = wdApp.Documents.Open(HomeDir$ & "\" & "Готовые документы" + "\Акт " + Название$ + "_" + Производитель$ + "_" + DataC$ + ".doc")


wdDoc.Range.Find.Execute FindText:="&date", Replacewith:=DataC$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&ID", Replacewith:=Название$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&OOO", Replacewith:=Производитель$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&Centr", Replacewith:=Центр$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&AG", Replacewith:=AG$, Replace:=2
wdDoc.Range.Find.Execute FindText:="&AT", Replacewith:=AT$, Replace:=2
wdDoc.Range.Find.Execute Replace:=wdReplaceALL


wdDoc.Save
wdDoc.Close
End If
i% = i% + 1
Loop
wdApp.Quit
MsgBox "Готово!"
End Sub

wdDoc.Range.Find.Execute FindText:="&ID", Replacewith:=Название$, Replace:=2