Страницы: 1
RSS
Как обойти копирование с выше 255 символов
 
Здравствуйте подскажите, очень нужна помощь. Как в этом коде обойти копирование с выше 255 символов:
Код
Sub ReplaceInWord()
    'имя шаблона Word с основным текстом и метками
    Const sWDTmpl As String = "Шаблон.docx"
     
    Dim objWrdApp As Object, objWrdDoc As Object, wdRange As Object
    Dim IsNeedClose As Boolean
    Dim ws As Worksheet
    Dim lr As Long, llastr As Long, lc As Long, llastc As Long
    Dim sPath As String, sToSavePath As String, sWDTmplFullName As String, sWDDocName As String
    Dim sFindVal As String, sReplaceVal As String
    On Error Resume Next
    'пытаемся подключится к объекту Word
    Set objWrdApp = GetObject(, "Word.Application")
    If objWrdApp Is Nothing Then
        'если приложение закрыто - создаем новый экземпляр
        Set objWrdApp = CreateObject("Word.Application")
        'делаем приложение видимым. По умолчанию открывается в скрытом режиме
        objWrdApp.Visible = True
        IsNeedClose = True
    End If
    'путь к папке с файлом кода
    'здесь же должен лежать файл шаблона Word
    sPath = ThisWorkbook.Path
    'добавляем разделитель папок, если его нет
    sPath = IIf(Right(sPath, 1) = Application.PathSeparator, "", sPath & Application.PathSeparator)
    'полный путь к файлу шаблона
    sWDTmplFullName = sPath & sWDTmpl
    'создаем папку для сохранения создаваемых файлов Word
    sToSavePath = sPath & Format(Now, "YYYY_MM_DD hh_mm")
    If Dir(sToSavePath, 16) = "" Then
        MkDir sToSavePath
    End If
    sToSavePath = IIf(Right(sToSavePath, 1) = Application.PathSeparator, "", sToSavePath & Application.PathSeparator)
     
    Set ws = Sheets("Word(копировать)")
    With ws
        'определяем последнюю заполненную ячейку на основании столбца А
        llastr = .Cells(.Rows.Count, 1).End(xlUp).Row
        'определяем последний столбец на основании столбца с метками
        llastc = .Cells(1, .Columns.Count).End(xlToLeft).Column
        'просмотр начинаем с 3-ей строки, т.к. именно с неё начинаются наши данные
        For lr = 3 To llastr
            'считываем фамилию с инициалами
            sWDDocName = .Cells(lr, 1).Value
            If sWDDocName <> "" Then
                'заменяем точки на пусто для удобочиатемости имен файлов
                sWDDocName = Replace(sWDDocName, ".", "")
                'составляем полный путь к создаваемому файлу,
                'при этом берем тоже расширение файла, что и шаблона
                sWDDocName = sToSavePath & sWDDocName & ".doc"
                'создаем новый документ Word на основании шаблона
                Set objWrdDoc = objWrdApp.Documents.Add(sWDTmplFullName)
                For lc = 1 To llastc
                    'запоминаем метку для поиска в файле Word
                    sFindVal = .Cells(1, lc).Value
                    'этим значением будем заменять текст метки
                    sReplaceVal = .Cells(lr, lc).Text
                    Set wdRange = objWrdDoc.Range
                    'заменяем метки {*} на текст из ячеек
                    wdRange.Find.ClearFormatting
                    wdRange.Find.Replacement.ClearFormatting
                    With wdRange.Find
                        .Text = sFindVal
                        .Replacement.Text = sReplaceVal
                        .Forward = True
                        .Wrap = 1 'wdFindContinue
                        .Format = False
                        .MatchCase = False
                        .MatchWholeWord = False
                        .MatchWildcards = False
                        .MatchSoundsLike = False
                        .MatchAllWordForms = False
                    End With
                    wdRange.Find.Execute Replace:=2 'wdReplaceAll
                Next lc
                'сохраняем созданный документ, но не добавляем в список последних открытых
                objWrdDoc.SaveAs FileName:=sWDDocName, AddToRecentFiles:=False
                'закрываем документ Word
                objWrdDoc.Close False
            End If
        Next
    End With
    If IsNeedClose Then
        'закрываем приложение Word если открывали его кодом
        objWrdApp.Quit
    End If
    'очищаем переменные Word
    Set objWrdDoc = Nothing
    Set objWrdApp = Nothing
    '
    MsgBox "Файлы созданы и сохранены в папке '" & sToSavePath & "'", vbInformation, "www.excel-vba.ru"
End Sub
 
Как можно обойти то, чего нет? Где в вашем коде копирование?
 
Ну или перенос, данных, просто я заметил, что если в ячейки больше 255 символов, то оги не переносятся в word. Это не мой, код вот ссылка
 
Подниму, тему вверх может кто-то поможет
Страницы: 1
Наверх