Ооо то что надо спасибо , теперь я понял как применить идею , ему тоже спасибо за помощь.
И так позволю себе подвести промежуточные итоги по улучшению данного макроса. Пример подкрепляю к данному сообщению, код макроса с различными вариантами его работы выкладываю ниже.
я к сожалению не так хорошо разбираюсь в написании макросов чтобы, так просто и легко написать Вам изменение для формирования договора по выделенной ячейки, могу сказать одно что это точно можно реализовать, т.к. я видел похожие решения на др. форумах, но как реализовать конкретно для этого макроса я не подскажу. Попробуйте обратится к Богу Excel 
, он думаю сможет подсказать идеи.
Но я могу предложить рабоче-крестьянский вариант выполнения Вашей задачи без внесения изменений в данный макрос. Как вариант можно использовать формулу ВПР и дополнительный столбец с отметкой какую строку нужно сформировать как договор, это если надо сформировать только один договор из списка (пример во вложении). Если же Вам необходимо сформировать несколько договоров то можно использовать ВПР + массив. Если не разберетесь пишите
И так позволю себе подвести промежуточные итоги по улучшению данного макроса. Пример подкрепляю к данному сообщению, код макроса с различными вариантами его работы выкладываю ниже.
| Цитата |
|---|
| Logistic написал: а что нужно изменить в коде ,что бы можно было формировать один договор ,выделили в таблице ячейку "Прізвище" Дзюба и получили договор по конкретной Фамилии. |
, он думаю сможет подсказать идеи.Но я могу предложить рабоче-крестьянский вариант выполнения Вашей задачи без внесения изменений в данный макрос. Как вариант можно использовать формулу ВПР и дополнительный столбец с отметкой какую строку нужно сформировать как договор, это если надо сформировать только один договор из списка (пример во вложении). Если же Вам необходимо сформировать несколько договоров то можно использовать ВПР + массив. Если не разберетесь пишите
| Код |
|---|
Const ИмяФайлаШаблона = "ШАБЛОНЫ/шаблон2.dot"
Const ИмяФайлаДоговора = "ДОГОВОРА/Договоры"
Const КоличествоОбрабатываемыхСтолбцов = 19
Const РасширениеСоздаваемыхФайлов = ".doc"
Sub СформироватьДоговоры()
ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
ПутьДоговора = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаДоговора)
'НоваяПапка = NewFolderName & Application.PathSeparator
Dim row As Range, pi As New ProgressIndicator
r = Cells(Rows.Count, "K").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
WA.Visible = True ' отобразить Word
For Each row In ActiveSheet.Rows("3:" & r)
With row
ФИО = Trim$(.Cells(11)) & " " & Trim$(.Cells(12)) & " " & Trim$(.Cells(13) & Get_Now)
Filename = ПутьДоговора & ФИО & РасширениеСоздаваемыхФайлов
pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
Set WD = WA.Documents.Add(ПутьШаблона): DoEvents
pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
For i = 11 To КоличествоОбрабатываемыхСтолбцов
FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))
' так почему-то заменяет не всё (не затрагивает таблицу)
'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True
pi.line3 = "Заменяется поле " & FindText
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
pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
WD.SaveAs Filename: 'сохранить созданый документ
'или
'WD.ExportAsFixedFormat OutputFileName:=Filename, ExportFormat:=17 ' сохранение в pdf
'или
'WD.PrintOut:'печать без сохранения
'WD.Close False: DoEvents 'закрыть созданый документ Word
p = p + a
End With
Next row
pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
'WA.Quit True: 'закрыть приложение Word
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
|
Изменено: - 18.01.2017 00:43:20
