Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")
    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            Номер = Trim$(.Cells(1))
            Filename = Папка & Номер & Расширение
           
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
            
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
               
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
            
            WD.SaveAs Filename: WD.Close False: DoEvents
            
        End With
    Next row