Добрый день, собрал себе excel документ, который формирует при помощи excel документа - заполненные документы по шаблонов word и excel
Только текст где более 255 символов для замены удалось реализовать при заполнении шаблонов word,
а вот для замены при заполнении шаблонов excel - все рушится. Пробую допилить Function ReplaceText, вот нужна помощь
Код |
---|
Function ReplaceText(ByVal ID As String, ByVal TextToReplace As String) As Boolean
Dim i As Long, MaxLen As Long
Dim Text As String, Mark As String
Dim iExcel As Object
MaxLen = 200
' Choose a character for Mark that is not in your data,
' and is not a special char: ~?*
Mark = "!"
If ID <> vbNullString Then
Do
Text = Left$(TextToReplace, MaxLen) & Mark
' Terminate the loop when all of TextToReplace has been processed
If Text = Mark Then Text = vbNullString
TextToReplace = Mid$(TextToReplace, MaxLen + 1)
iExcel.Sheets(1).Replace _
What:=ID, _
Replacement:=Text
ID = Mark
Loop Until Text = vbNullString
End If
End Function
|
Код |
---|
Sub CreateDoc()
Dim MyArray(), BasePath As String, iFolder As String, iTemplate As String
Dim tmpArray, tmpSTR As String, iRow As Long, iColl As Long, i As Long, j As Long, q As Long
Dim iExcel As Object
Application.ScreenUpdating = 0
On Error GoTo iEnd
iFolder = Range("FILE_WORD").Value: If Right(iFolder, 1) <> "\" Then iFolder = iFolder & "\"
iTemplate = Range("FILE_TEMPLATE").Value: If Right(iTemplate, 1) = ";" Then iTemplate = Left(iTemplate, Len(iTemplate) - 1)
BasePath = ThisWorkbook.Path & "\Result\": ' Call FolderCreateDel(BasePath)
With Sheets("data")
iRow = .UsedRange.Row + .UsedRange.Rows.Count - 1: iColl = .UsedRange.Column + .UsedRange.Columns.Count - 1
MyArray = .Range(.Cells(1, 1), .Cells(iRow, iColl)).Value
End With
'перебираем массив
For i = 2 To iRow
If MyArray(i, 1) = "ok" Then
'перебираем указанные excel-шаблоны
tmpSTR = iFolder & tmpArray(q) & ".xlsx"
If Len(Dir(tmpSTR)) > 0 Then
Set iExcel = Workbooks.Open(tmpSTR)
'делаем замену переменных
For j = 4 To iColl
iExcel.Sheets(1).Cells.Replace MyArray(1, j), MyArray(i, j)
'Call ReplaceText(MyArray(1, j), MyArray(i, j))
Next j
iExcel.SaveAs Filename:=BasePath & MyArray(i, 2) & " - " & tmpArray(q) & ".xlsx" '".docx" ', FileFormat:=wdFormatXMLDocument
iExcel.Close False: Set iExcel = Nothing
End If
|