Страницы: 1
RSS
Вставка цикла для обхода ограничения в 255 символов. Вставка из excel в word., Run-time error ‘5854’: Слишком длинный строковый параметр
 
Добрый день. Есть макрос, позволяющий переносить текст из ячеек excel в вордовский шаблон. Однако, если в ячейку добавить больше 255 символов, то офис ругается и выдает ошибку "Run-time error ‘5854’: Слишком длинный строковый параметр". В инете пишут, что для лечения этой заразы необходимо сделать цикл, что у меня никак не получается. Люди добрые, помогите глупцу понять, как сделать этот самый цикл, ибо уже два дня как онный у меня не получается. Сам код и файлы прикладываю.
Код
Const ИмяФайлаШаблона = "Концепция образец для маркоса.docm"
Const КоличествоОбрабатываемыхСтолбцов = 169
Const РасширениеСоздаваемыхФайлов = ".docx"

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(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

Изменено: Salomon - 20.03.2017 17:40:29
 
Файлы
 
Как то удалось в итоге решить данную проблему? у самого такой же вопрос.
 
Самостоятельно решил данный вопрос. Может быть кому будет полезно:    
Код
Dim FindText As String ' что ищем
    Dim ReplaceText As String ' на что меняем
    Dim PathTemp As String ' путь к шаблону документа
    Dim WA As Object
    Dim WD As Object
    
    Set WA = CreateObject("Word.Application")
    Set WD = WA.Documents.Add(PathTemp) ' на основании шаблона (передаем полный путь к нему)создаем новый документ Word.
' код по замене значений
metka1:
    With WD.Range.Find
        .Text = FindText
        If Len(ReplaceText) > 255 Then 'поскольку Find.ReplaceText не может принимать строку больше 255 символов,
'           пришлось в "цикле" подставлять строку по кусочкам, каждый раз добавляя в нее FindText,
'           чтобы в дальнейшем не потерять место, куда вставляем "хвостик" длинной строки
            .Replacement.Text = Left(ReplaceText, 255 - Len(FindText)) & FindText
            ReplaceText = Right(ReplaceText, Len(ReplaceText) - (255 - Len(FindText)))
            .Forward = True
            .Wrap = 1
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute Replace:=2
            GoTo metka1
        Else
            .Replacement.Text = ReplaceText 'текст на который меняем
        End If
        .Forward = True
        .Wrap = 1
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=2
    End With
Изменено: Борис13 - 20.11.2020 13:15:24
 
Борис13,. а можете файлик архив правильный скинуть сюда
Страницы: 1
Наверх