![]() |
Макрос создания документов Word по данным таблицы Excel
Уважаемые программисты прошу помочь!
Нужно на работе автоматизировать свою работу, чтобы не заниматься однообразной работой. Нашел на сайте готовый макрос http://excelvba.ru/code/CreateWordDocuments Но не могу до конца разобраться как подстроить его под себя. 1) Как сделать так чтобы макрос создавал документы Word и вставлял данные со второй строки в Excel Я так понимаю нужно сделать следующие исправления (я их выделил жирным) r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 1 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("2:" & r) 2) Как заставить макрос чтобы при сохранении документов Word из шаблона, сохранял их в одну определенную папку а не создавал при каждом выполнении новую пример Договоры, сформированные 06-06-2011 в 12-26-44 3) Как заставить макрос, чтобы при создании нового документа, имя документа создавалось не по трем столбцам а по одному (то есть по столбцу 1) 4) Как сделать так чтобы формировались документы не по всем строчкам, а только по нужным с помощью макроса например если допустим в столбце А стоит слово noPrint, то заявки не создаются, если ни чего не стоит то создаются. Жду решений, заранее спасибо! Сам макрос ниже Const ИмяФайлаШаблона = "шаблон.dot" Const КоличествоОбрабатываемыхСтолбцов = 8 Const РасширениеСоздаваемыхФайлов = ".doc" Sub СформироватьДоговоры() ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона) НоваяПапка = 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 WD = WA.Documents.Add(ПутьШаблона): 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 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.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 |
5) И еще один момент забыл указать как сделать так, чтобы выборка из Excel была ни только с первого листа, а со всех листов в книге.
|
RusGor, расскажите своими словами, что Вам нужно. Приведите пример рабочей книги Excel.
|
Есть примерно такая же задача, кто готов взяться?
|
Всем привет. А вам обязательно делать это скриптами и макросом?
Если я правильно понял задачу, то у меня была такая же и я ее решал вот так. https://www.youtube.com/watch?v=spmtcywy9Wo Стандартный функционал и скрипты не нужны. |
Время: 17:32. |
Время: 17:32.
© OSzone.net 2001-