|
|
Регистрация Восстановить пароль |
Повторная активизация e-mail |
Регистрация | Задать вопрос |
Заплачу за решение |
Новые сообщения |
Сообщения за день |
Расширенный поиск |
Правила |
Всё прочитано |
|
|
Опции темы | Поиск в этой теме |
13.03.2016, 10:08 | #11 |
Пользователь
Регистрация: 12.03.2016
Сообщений: 17
|
как правильно прописать такое выражение применительно к моей ситуации или лучше продублироваить текст полностью
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 Последний раз редактировалось Alex6375; 13.03.2016 в 10:44. |
13.03.2016, 10:52 | #12 |
2 the Nation Glory
Старожил
Регистрация: 27.05.2014
Сообщений: 3,289
|
...
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы. |
13.03.2016, 11:06 | #13 |
Пользователь
Регистрация: 12.03.2016
Сообщений: 17
|
ругается на Next i
|
13.03.2016, 12:02 | #14 |
2 the Nation Glory
Старожил
Регистрация: 27.05.2014
Сообщений: 3,289
|
Забей на это, сохрани нервы.
За 100₴, думаю, можно найти кто напишет макроса, но это при условии внятного и полного описания задания(не так как в этой теме, здесь нет ни одного понятного описания что нужно сделать)
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы. |
13.03.2016, 12:42 | #15 |
Пользователь
Регистрация: 12.03.2016
Сообщений: 17
|
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 |
13.03.2016, 13:20 | #16 |
Пользователь
Регистрация: 12.03.2016
Сообщений: 17
|
Я просто пытаюсь сформировать 4 разных документа с одной таблицы, пока только сохраняет один документ
|
13.03.2016, 13:49 | #17 |
Пользователь
Регистрация: 12.03.2016
Сообщений: 17
|
сам файл
|
13.03.2016, 14:20 | #18 |
Новичок
СтарожилДжуниор
Регистрация: 05.02.2008
Сообщений: 9,487
|
вот это не смущает
Код:
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
|
13.03.2016, 15:22 | #19 |
2 the Nation Glory
Старожил
Регистрация: 27.05.2014
Сообщений: 3,289
|
Названия столбцов не совпадают с метками в dot файлах: где {Призвище} где {Прізвище}.
почему цикл Код:
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы. |
13.03.2016, 17:07 | #20 |
Пользователь
Регистрация: 12.03.2016
Сообщений: 17
|
Я извеняюсь за недоделаные шаблоны. Может я ищу не там. Думаю что в папке должны сохранятся не имена из таблицы а сами названия шаблонов тогда их и будет 4
|
|
Похожие темы | ||||
Тема | Автор | Раздел | Ответов | Последнее сообщение |
Перенос данных из Excel в Word | driver_ok | Microsoft Office Word | 0 | 25.11.2015 16:55 |
перенос данных из excel в word | D_e_n_n | Microsoft Office Excel | 9 | 14.03.2011 08:06 |
Выгрузка данных из excel in word. | noc | Microsoft Office Excel | 5 | 22.11.2010 12:48 |
Экспорт данных из Excel в Word | MSusik | Microsoft Office Excel | 9 | 15.11.2010 09:41 |