Здравствуйте подскажите, очень нужна помощь. Как в этом коде обойти копирование с выше 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
|