нужна помощь при написании макроса... тема уже заезженная, но подробного ответа так и не нашел... ошибка макроса "слишком длинный строковый параметр"...
Есть ли у кого нибудь актуальное решение данного вопроса?
Скрытый текст
Код
С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
[COLOR=#ee1d24] .Replacement.Text = ReplaceText[/COLOR]
.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
Оформление кода - кнопка <...> на панели над полем для ввода сообщения. Длинные листинги - под спойлер (кнопка sp). Но правильнее - показывать небольшой файл-пример. Раздел Работа
Понятно, ну не таким образом это делается, шаблон готовится и вместо ваших пометок, ставятся закладки, потом уже не через замену, а штатным механизмом им присваиваются те значения, что вы хотите. А .Replace все ж ограничен в 255 символов.