Уважаемые форумчане, зная вашу отзывчивость, хочу попросить помочь с решением проблемы, которую я не могу решить с помощью "Поиска".
Суть проблемы такова:
я, пользуясь кодом с форума, заполняю шаблон в Word из Excel. Всё бы хорошо, но не получается заполнить значения, которые записаны в редакторе формул.
К сообщению прилагаю архив с 3-мя файлами : Пример в Excel с макросом, Пример в Word и результат работы макроса.
Суть проблемы такова:
я, пользуясь кодом с форума, заполняю шаблон в Word из Excel. Всё бы хорошо, но не получается заполнить значения, которые записаны в редакторе формул.
К сообщению прилагаю архив с 3-мя файлами : Пример в Excel с макросом, Пример в Word и результат работы макроса.
Код |
---|
Sub ReplaceInWord() 'Отключаем обновление экрана Application.ScreenUpdating = False 'имя шаблона Word с основным текстом и метками Const sWDTmpl As String = "Пример.docx" 'Шаблон оформления Dim objWrdApp As Object, objWrdDoc As Object, wdRange As Object Dim IsNeedClose As Boolean Dim wsOformlenie 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 wsOformlenie = Worksheets("Лист1") With wsOformlenie 'определяем последнюю заполненную ячейку на основании столбца А 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 'Обновляем экран Application.ScreenUpdating = True ' MsgBox "Файлы созданы и сохранены в папке '" & sToSavePath End Sub |