Excel Word VBA: формирование документа word на основании содержимого excel

[swenny]

Всем добрый день. Требуется Ваша помощь в решении одной задачки. В общем имеется одна табличка из которой нужно вставить данные в определенное место в документ Microsoft Word. Задача вроде бы решена, хотя возможно и криво. Но проблема в том, что на выходе теряется форматирование исходного файла образца. Подскажите пожалуйста,как можно решить эту проблему? Всем откликнувшимся заранее огромное спасибо!

[вложение удалено администратором]

[Администратор]

Для замены используйте метод "Find" программы "Word":

Макрос

Sub dover()

    Dim wdApp As Object, wdDoc As Object
    Dim FIO$, GOROD$, SER$, NUM$, HomeDir$, i&

   
    '1. Запись пути файла-результата в переменную.
    HomeDir = ThisWorkbook.Path
   
    '2. Запуск программы "Word".
    Set wdApp = CreateObject(Class:="Word.Application")
   
    '3.
    ' Движение по эксель-листу.
    For i = 3 To 5 Step 1
     
        '1) Копирование данных из эксель в переменные.
        FIO = Cells(i, 2).Value
        GOROD = Cells(i, 3).Value
        SER = Cells(i, 4).Value
        NUM = Cells(i, 5).Value
       
        '2) Создание файла-результата.
        FileCopy HomeDir + "\dover.doc", HomeDir + "\" + FIO + ".doc"
       
        '3) Открытие файла-результата.
        Set wdDoc = wdApp.Documents.Open(HomeDir + "\" + FIO + ".doc")
   
        '4) Замена.
        ' Replace:=2 - wdReplaceAll
        wdDoc.Range.Find.Execute FindText:="&D", ReplaceWith:=Day(Now), Replace:=2
        wdDoc.Range.Find.Execute FindText:="&M", ReplaceWith:=Month(Now), Replace:=2
        wdDoc.Range.Find.Execute FindText:="&Y", ReplaceWith:=Year(Now), Replace:=2
        wdDoc.Range.Find.Execute FindText:="&GOROD", ReplaceWith:=GOROD, Replace:=2
        wdDoc.Range.Find.Execute FindText:="&FIO", ReplaceWith:=FIO, Replace:=2
        wdDoc.Range.Find.Execute FindText:="&NUM", ReplaceWith:=NUM, Replace:=2
        wdDoc.Range.Find.Execute FindText:="&SER", ReplaceWith:=SER, Replace:=2
           
        '5) Закрытие файла-результата.
        ' SaveChanges:=-1 - wdSaveChanges
        wdDoc.Close SaveChanges:=-1
       
    Next i
   
    '4. Закрытие программы "Word".
    wdApp.Quit
   
    '5. Сообщение.
    MsgBox "ГОТОВО!", vbInformation

End Sub

[свернуть]

[swenny]

Спасибо большое. А подскажите пожалуйста, возможно ли сделать так, чтобы все доверенности формировались в одном документе word на отдельных листах.

[Администратор]

Макрос

Sub dover()

    Dim wdApp As Object, wdDoc As Object
    Dim FIO$, GOROD$, SER$, NUM$, HomeDir$, i&, lngStart&

   
    '1. Запись в переменную пути для файла-результата.
    HomeDir = ThisWorkbook.Path
   
    '2. Запуск программы "Word".
    Set wdApp = CreateObject(Class:="Word.Application")
    wdApp.Visible = True
   
    '3. Создание файла-результата.
    FileCopy HomeDir + "\dover.doc", HomeDir + "\" + "файл-результат" + ".doc"
       
    '4. Открытие файла-результата.
    Set wdDoc = wdApp.Documents.Open(HomeDir + "\" + "файл-результат" + ".doc")
   
    '5. Очистка файла-результата (чтобы упростить код).
    wdDoc.Range.Text = ""
   
    '6.
    ' Движение по эксель-листу.
    For i = 3 To 5 Step 1
       
        '1) Создание страницы. Если это первый раз, то не нужно создавать страницу.
        If wdDoc.Range.Text <> Chr(13) Then
            wdDoc.Range(wdDoc.Range.End - 1, wdDoc.Range.End - 1).InsertBreak Type:=0
        End If
       
        '2) Запоминание позиции:
            '1) куда вставить новые данные;
            '2) откуда будет осуществляться поиск и замена.
        lngStart = wdDoc.Range.End - 1
   
        '3) Копирование данных в файл-результат из файла-шаблона.
        wdDoc.Range(lngStart, lngStart).InsertFile Filename:=HomeDir + "\dover.doc", Link:=False
     
        '4) Копирование данных из эксель в переменные.
        FIO = Cells(i, 2).Value
        GOROD = Cells(i, 3).Value
        SER = Cells(i, 4).Value
        NUM = Cells(i, 5).Value
       
        '5) Замена.
        ' Replace:=2 - wdReplaceAll
        wdDoc.Range(lngStart, lngStart).Find.Execute FindText:="&D", ReplaceWith:=Day(Now), Replace:=2
        wdDoc.Range(lngStart, lngStart).Find.Execute FindText:="&M", ReplaceWith:=Month(Now), Replace:=2
        wdDoc.Range(lngStart, lngStart).Find.Execute FindText:="&Y", ReplaceWith:=Year(Now), Replace:=2
        wdDoc.Range(lngStart, lngStart).Find.Execute FindText:="&GOROD", ReplaceWith:=GOROD, Replace:=2
        wdDoc.Range(lngStart, lngStart).Find.Execute FindText:="&FIO", ReplaceWith:=FIO, Replace:=2
        wdDoc.Range(lngStart, lngStart).Find.Execute FindText:="&NUM", ReplaceWith:=NUM, Replace:=2
        wdDoc.Range(lngStart, lngStart).Find.Execute FindText:="&SER", ReplaceWith:=SER, Replace:=2
       
    Next i
   
    '7. Закрытие файла-результата.
    ' SaveChanges:=-1 - wdSaveChanges
    wdDoc.Close SaveChanges:=-1
       
    '8. Закрытие программы "Word".
    wdApp.Quit
   
    '9. Сообщение.
    MsgBox "ГОТОВО!", vbInformation

End Sub

[свернуть]