Подстановка данных из excel в word

[Alex6375]

как правильно прописать такое выражение применительно к моей ситуации или лучше продублироваить текст полностью

Dim c As Integer, i As Integer, j As Integer

For c = 1 To 3
For i = 1 To 6
For j = 1 To 2
Worksheets(c).Cells(i, j).Value = 100
Next j
Next i
Next c

[Aleksandr H.]

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

вопрос расплывчатый, я не смог понять о чем собственно речь

можете просто подождать пока подтянутся более сообразительные люди, а можете конкретизировать вопрос до состояния, когда он понятен не только Вам, но и остальным

...

[Alex6375]

ругается на Next i

[Aleksandr H.]

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

[Alex6375]

Const ИмяФайлаШаблона1 = "шаблон1.dot"
Const ИмяФайлаШаблона2 = "шаблон2.dot"
Const ИмяФайлаШаблона3 = "шаблон3.dot"
Const ИмяФайлаШаблона4 = "шаблон4.dot"
Const КоличествоОбрабатываемыхСтолбцов = 8
Const РасширениеСоздаваемыхФайлов = ".doc"

Sub СформироватьДоговоры()
ПутьШаблона1 = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона1)
ПутьШаблона2 = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона2)
ПутьШаблона3 = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона3)
ПутьШаблона4 = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона4)
НоваяПапка = NewFolderName & Application.PathSeparator
Dim row As Range, pi As New ProgressIndicator
r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub

pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
pi.StartNewAction , s1, "Запуск приложения Microsoft Word"

' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application ' c подключением библиотеки Word
Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application") ' без подключения библиотеки Word

For Each row In ActiveSheet.Rows("3:" & r)
With row
ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(2)) & " " & Trim$(.Cells(3))
Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов

pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", Договор
Set WD1 = WA.Documents.Add(ПутьШаблона1): DoEvents
Set WD2 = WA.Documents.Add(ПутьШаблона2): DoEvents
Set WD3 = WA.Documents.Add(ПутьШаблона3): DoEvents
Set WD4 = WA.Documents.Add(ПутьШаблона4): DoEvents
pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
For i = 1 To КоличествоОбрабатываемыхСтолбцов
FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))

' так почему-то заменяет не всё (не затрагивает таблицу)
'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True

pi.line3 = "Заменяется поле " & FindText
With WD1.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
With WD2.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
With WD3.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
With WD4.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
pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", Договор, " "
WD1.SaveAs Filename: WD1.Close False: DoEvents
WD2.SaveAs Filename: WD2.Close False: DoEvents
WD3.SaveAs Filename: WD3.Close False: DoEvents
WD4.SaveAs Filename: WD4.Close False: DoEvents
p = p + a
End With
Next row

pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
WA.Quit False: pi.Hide
msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
MsgBox msg, vbInformation, "Готово"
End Sub










Function NewFolderName() As String
NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Договоры, сформированные " & Get_Now)
MkDir NewFolderName
End Function

Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

[Alex6375]

Я просто пытаюсь сформировать 4 разных документа с одной таблицы, пока только сохраняет один документ

[Alex6375]

сам файл

[IgorGO]

вот это не смущает

WD1.SaveAs Filename: WD1.Close False: DoEvents
WD2.SaveAs Filename: WD2.Close False: DoEvents
WD3.SaveAs Filename: WD3.Close False: DoEvents
WD4.SaveAs Filename: WD4.Close False: DoEvents

Вы последовательно, под одним и тем же именем, сохраняете 4-е файла, ясен пень, что на диске останется только последний из них.

[Aleksandr H.]

Названия столбцов не совпадают с метками в dot файлах: где {Призвище} где {Прізвище}.
почему цикл

For i = 4 To КоличествоОбрабатываемыхСтолбцов

начинается с 4 а не с 1. В договорах Прізвище, ім’я, побатькові не надо менять?

[Alex6375]

Я извеняюсь за недоделаные шаблоны. Может я ищу не там. Думаю что в папке должны сохранятся не имена из таблицы а сами названия шаблонов тогда их и будет 4