Всем, Добрый день.
нужна помощь при написании макроса... тема уже заезженная, но подробного ответа так и не нашел... ошибка макроса "слишком длинный строковый параметр"...
Пример файлов в приложении пароль архива 54989
нужна помощь при написании макроса... тема уже заезженная, но подробного ответа так и не нашел... ошибка макроса "слишком длинный строковый параметр"...
Код |
---|
Сonst ИмяФайлаШаблона = "Шаблон Протокола.dot" КоличествоОбрабатываемыхСтолбцов = 11 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 - 62 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("63:" & r) With row ИмяПротокола = Trim$(.Cells(10)) 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(61, 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, "Готовые протоколы по службам") 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 |
Пример файлов в приложении пароль архива 54989