Автозаполнение договоров

[АлександрТосно]

Всем добрый вечер!
прошу помощи, есть 4 документа шаблона Word с разными договорами и своим именем, есть таблица в Excel с нужными данными подставляемыми в свой договор.
необходимо чтобы при выполнении макроса, а именно выделяя нужную ячейку с тем именем, которым надо сохранить в формате .docx, но он сохраняет только то что я укажу:
FName = ob1.Cells(f_r, stb)
objDoc.SaveAs Filename:=path_f & "\Договор_" & FName

я бы хотел чтобы когда я хочу сохранить файл, то он бы сохранялся с именем документа (шаблона) с именем той выделенной ячейкой, а так же создавалась одноименная папка в нужном мне месте.

Sub Generator()
Dim ObWord As Word.Application
Dim objDoc As Word.Document
Dim file As String
Set ob1 = ActiveWorkbook.ActiveSheet ' теперь переменная ob1 будет содержать ссылку на текущий лист активной книги
f_r = Selection.Row ' определяем номер выбранной строки
stb = Selection.Column ' определяем номер выбранного столбца
f_c = Selection.CurrentRegion.Columns(Sel ection.CurrentRegion.Columns.Count) .Column ' определяем номер последнего столбца в данной таблице
path_f = ThisWorkbook.Path 'определяем текущую папку
file = Application.GetOpenFilename("Excel Files (*.docx;*.doc), *docx;*.doc") ' открывается диалоговое окно "Открытие документа"
If Dir(file) = Empty Then
Exit Sub
Else
' запускаем Word, открываем выбранный документ
Set ObjWord = CreateObject("Word.Application")
With ObjWord
.Visible = True
.Documents.Open Filename:=file
Set objDoc = .ActiveDocument
End With
With objDoc.Range
For j = 1 To f_c ' цикл по всем столбцам таблицы
isk_zn = ob1.Cells(1, j) 'искомое значение - находится в первой строке нашей таблицы
zamen_zn = ob1.Cells(f_r, j) 'значение для замены
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
'осуществляем замену
With .Find
.Text = isk_zn
.Replacement.Text = zamen_zn
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
.Find.Execute Replace:=wdReplaceAll
Next j
' сохраняем документ в том же месте что и книга с макросом, имя документа - значение из выделенной ячейки
FName = ob1.Cells(f_r, stb)
objDoc.SaveAs Filename:=path_f & "\" & FName
objDoc.Close
ObjWord.Quit
End With
Set objDoc = Nothing
Set ObjWord = Nothing
ob1.Activate
End If
End Sub

[EducatedFool]

Посмотрите готовое решение
http://excelvba.ru/programmes/FillDocuments

В этой надстройке есть весь необходимый вам функционал.