Заполнение документа Excel по шаблону из базы даных Excel

[Сергей Цахло]

а как это в макрос записать? чтоб он находил на листе шаблона {фио} и заменял его ? потом сохранинял в новом файле.

[Сергей Цахло]

вот что у меня получилось:

Const ИмяФайлаШаблона = "Шаблон.xlsx"
Const КоличествоОбрабатываемыхСтолбцов = 8
Const РасширениеСоздаваемыхФайлов = ".xlsx"

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 wsS As Ranges, wsb As Object, wsWS As Object: Set wsb = Workbooks.Open(ПутьШаблона)
    'Set wsS = Worksheets("База")
    
    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(2)) & " " & Trim$(.Cells(3))
            Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов

            pi.StartNewAction p, p + A / 3, "Создание нового файла на основании шаблона", ФИО
            Set wsWS = wsb.Worksheets("Лист1").Select: DoEvents
            
            pi.StartNewAction p + A / 3, p + A * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(1, i): ReplaceText = Trim$(.Cells(i))

                pi.line3 = "Заменяется поле " & FindText
                With wsWS.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, "Сохранение файла ...", ФИО, " "
            wsWS.SaveAs Filename: wsWS.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

Открывает шаблон ищет, но не может заменить - шибка, немогу розобраться как макросу указать чтоб он менял найденое (ошибка на выделенное красным)

[doober]

(ошибка на выделенное красным)

Ничего удивительного в этом нет.
Вы Ворд с Excel попутали.
Set wsWS = wsb.Worksheets("Лист1").Select

[Сергей Цахло]

скажем я не попутал, а макрос для ворда пытаюсь переделать под ексель. и не могу правельно задать цикл для замены найденого на выбраном листе

[Сергей Цахло]

в макросы только вникать начал и у меня ещё не хватает мозга переделать не говоря уже о написании с нуля. Принцып действия понимаю а вот как правельно написать не знаю..(

[doober]

Тогда должно быть так

 Dim wsS As Ranges, wsb As Object, wsWS As Object
 Set wsb = CreateObject("Word.Application")
 Set wsWS = wsb.documents.Open(ПутьШаблона)

[Сергей Цахло]

для ворда я знаю как, а мне нужно для екселя