Vba создание шаблона word

Всем привет. Написал отдельный модуль (класс), вроде работает. Прикладываю в спойлер.

Ну и пример использования. Если кто найдет ошибку, с радостью приму комментарии

Set act = New WordGenerator
With act
 .template_add "courtиск.docx" 'Добавили шаблон в папке templates проекта
 .template_add "С:претензия.docx" 'добавили шаблон абсолютного пути
 .dialog = True 'И этого нам мало, мы спрашиваем юзера, чтобы тоже указал шаблоны
 .multiselect = True 'да и пусть еще мог бы выбрать сразу несколько в диалоговом окне
 .closeafter = True 'Юзер не хочет редактировать готовый файл, закрываем его
 .marker = "Иванов 2017" 'а это припишется к каждому создаваемому файлу
 .SetSaveFolder = "Все по Иванову"  'а это папка, куда будет складываться все с этого объекта

 .pair_add "ФИО", "Иванов Иван Иванович"  'парочка пар на замену, можно и сотню
 .pair_add "[должность]", "директор"

 .Start 'запускаем процесс, смотрим как открываются ворд файлики, 
         'производятся замены. сохраняется и закрывается, результат ищем в папках
End With

This problem is ideal for automation. To me it seems you should be able to have a basic template and fill in the information pretty much purely based on the Excel spreadsheet with the Machine information.

Bookmarks in Word are you friend here. You can use them to initially place your tables and figures and also to update them if new information becomes available (although this requires extra effort).
I’ve done a fair bit of work importing data from Excel to Word as tables and would definitely recommend against importing tables as pictures. Your file size will balloon out really quickly and people that want to electronically extract data from the tables will want to stab you with rusty teaspoons.

From the information you’ve provided I’d probably begin your code in Excel with the Excel template as the active workbook. This is the way I’d set it up:

• Start with an add-in that displays a ribbon tab. This can be used for any ‘machine’ excel template.
• Use OLE automation to open Word and create a new document from the Word template (there is plenty of info on the net to do this)
• Read in the structure of the document from the Excel Template and set up the word document. Since you know the layout you can populate placeholders (bookmarks) for all of the figures and tables along with captions.
• Loop through all the tables and insert them first. The trick with inserting tablular data from Excel to Word is to insert the table as delimited text and then convert it to a table.
• Loop through and insert all the figures.
• If you encapsulate the figures with a bookmark and add a bookmark to the tables you can then update them individually as needed.

Note, that none of these options are that trivial by themselves. If you want to apply extra formatting like bold headings, merged cells or tables that split over pages then it is considerably more work.

You can use field codes to sequentially update table and figure numbers and again bookmarks to provide cross-references.

The question is quite broad to provide a lot of code, but the following example subs and functions should be enough to get you started. If you have further questions you should start a new question for them.

With an input of the Word Document (created from the Template and already populated with the bookmarks defining table locations) and the names of all the tables you have, the following functions will populate those tables into Word.

Sub PopulateTables(wdDoc As Word.Document, vTableArray As Variant)
    Dim ii As Integer, rInputData As Range

    'Loop through all the bookmarks
    For ii = LBound(vTableArray) To UBound(vTableArray)
        'Get the name of the current table from the list in the Excel template
        sTableName = vTableArray(ii)

        'Check if the bookmark exists in the document
        If wdDoc.Bookmarks.Exists("tblplc_" & sTableName) Then
            'Use the function to check if there is a table already at the bookmark
            Call CheckTableBookMark(wdDoc, "tblplc_" & sTableName)

            'Get the range of the information to be put into the table here.
            'THIS WILL BE YOUR OWN CUSTOM FUNCTION
            Set rInputData = GetMyInputData(sTableName)

            'Insert the data into Word
            Call CreateTableFromString(wdDoc.Bookmarks("tblplc_" & sTableName).Range, rInputData)
        End If
    Next ii
End Sub

This function will delete any existing table at a bookmark and ensure there is a fresh bookmark for new data:

Sub CheckTableBookMark(wdDoc As Word.Document, sTargetBM As String)
    'Function to delete any existing tables at a bookmark.

    With wdDoc
        .Activate
        .Bookmarks(sTargetBM).Select

        'If the bookmark has a table in it then we need to delete it
        If .Bookmarks(sTargetBM).Range.Tables.Count > 0 Then
            .Bookmarks(sTargetBM).Range.Tables(1).Delete

            'If the bookmark was 'inside' the table it may have been deleted.  Put it back in
            If Not .Bookmarks.Exists(sTargetBM) Then
                .Application.Selection.TypeParagraph
                .Application.Selection.MoveLeft Unit:=wdCharacter, Count:=1
                .Bookmarks.Add sTargetBM
            Else
                .Bookmarks(sTargetBM).Range.Select
                .Application.Selection.TypeParagraph
            End If

            'Do custom formatting here as required.
            .Bookmarks(sTargetBM).Range.Style = "Normal"
            .Bookmarks(sTargetBM).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
        End If
    End With
End Sub

The following two functions will Build a string containing the data and then convert it into a table for you:

Sub CreateTableFromString(ByRef rWordRange As Word.Range, rFromRange As Range)
    Dim tblWordTarget As Word.Table

    'Build the data from the Excel Spreadsheet and set it to the word range
    rWordRange.Text = BuildDataString(rFromRange)
    Set tblWordTarget = rWordRange.ConvertToTable(vbTab, AutoFitBehavior:=wdAutoFitFixed, DefaultTableBehavior:=wdWord8TableBehavior)

    'Do stuff with the table here (eg apply formatting etc)

    Set tblWordTarget = Nothing
End Sub

Function BuildDataString(rFromRange As Range) As String
    Dim sData As String, nrRow As Long, nrCol As Integer, iTotalColumns As Integer

    'Convert the input range to a variable and determine the number of columns
    vData = rFromRange.Value
    iTotalColumns = UBound(vData, 2)

    'Loop through all the elements in the array
    For nrRow = LBound(vData, 1) To UBound(vData, 1)
        For nrCol = 1 To iTotalColumns
            'Depending on what type of data is encountered either add it to the string or substitute something
            'You'll want to modify this as needed
            If IsError(vData(nrRow, nrCol)) Then
                sData = sData & "Error"
            ElseIf vData(nrRow, nrCol) = "" Or vData(nrRow, nrCol) = 0 Or vData(nrRow, nrCol) = "-" Then
                sData = sData & VBA.Chr$(150)
            Else
                sData = sData & vData(nrRow, nrCol - iIncrement)
            End If

            'Use tab delimiters for Word to know where the columns are
            If nrCol < iTotalColumns Then sData = sData & vbTab
        Next nrCol

        'Add a carriage return for each new line
        If nrRow < UBound(vData, 1) Then sData = sData & vbCr
    Next nrRow

    'Return the completed string
    BuildDataString = sData
End Function

Категория: Excel

Опубликовано: 18 июня 2020

Просмотров: 12527

Sub main()
Dim wdApp As Object
Dim wdDoc As Object

HomeDir$ = ThisWorkbook.Path
Set wdApp = CreateObject("Word.Application")
i% = 2
Do
If Cells(i%, 1).Value = "" Then Exit Do
If Cells(i%, 1).Value <> "" Then

NPP$ = Cells(i%, 1).Text
ID$ = Cells(i%, 2).Text
Adress$ = Cells(i%, 3).Text
SN$ = Cells(i%, 4).Text

DataC$ = Date

FileCopy HomeDir$ + "template.doc", HomeDir$ + "" + NPP$ + "_" + ID$ + "_" + DataC$ + ".doc"
Set wdDoc = wdApp.Documents.Open(HomeDir$ + "" + NPP$ + "_" + ID$ + "_" + DataC$ + ".doc")

wdDoc.Range.Find.Execute FindText:="&date", ReplaceWith:=DataC$

wdDoc.Range.Find.Execute FindText:="&id", ReplaceWith:=ID$
wdDoc.Range.Find.Execute FindText:="&adress", ReplaceWith:=Adress$
wdDoc.Range.Find.Execute FindText:="&sn", ReplaceWith:=SN$

wdDoc.Save
wdDoc.Close
End If

i% = i% + 1
Loop
wdApp.Quit
MsgBox "Готово!"

End Sub

It’s been a long time since I asked this question, and my solution has undergone more and more refinement. I’ve had to deal with all sorts of special cases, such as values that come directly from the workbook, sections that need to be specially generated based on lists, and the need to do replacements in headers and footers.

As it turns out, it did not suffice to use bookmarks, as it was possible for users to later edit documents to change, add, and remove placeholder values from the documents. The solution was in fact to use keywords such as this:

This is just a page from a sample document which uses some of the possible values that can get automatically inserted into a document. Over 50 documents exist with completely different structures and layouts, and using different parameters. The only common knowledge shared by the word documents and the excel spreadsheet is a knowledge of what these placeholder values are meant to represent. In excel, this is stored in a list of document generation keywords, which contain the keyword, followed by a reference to the range that actually contains this value:

These were the key two ingredients required. Now with some clever code, all I had to do was iterate over each document to be generated, and then iterate over the range of all known keywords, and do a search and replace for each keyword in each document.

First, I have the wrapper method, which takes care of maintaining an instance of microsoft word iterating over all documents selected for generation, numbering the documents, and doing the user interface stuff (like handling errors, displaying the folder to the user, etc.)

' Purpose: Iterates over and generates all documents in the list of forms to generate
'          Improves speed by creating a persistant Word application used for all generated documents
Public Sub GeneratePolicy()
    Dim oWrd As New Word.Application
    Dim srcPath As String
    Dim cel As Range

    If ERROR_HANDLING Then On Error GoTo errmsg
    If Forms.Cells(2, FormsToGenerateCol) = vbNullString Then _
        Err.Raise 1, , "There are no forms selected for document generation."
    'Get the path of the document repository where the forms will be found.
    srcPath = FindConstant("Document Repository")
    'Each form generated will be numbered sequentially by calling a static counter function. This resets it.
    GetNextEndorsementNumber reset:=True
    'Iterate over each form, calling a function to replace the keywords and save a copy to the output folder
    For Each cel In Forms.Range(Forms.Cells(2, FormsToGenerateCol), Forms.Cells(1, FormsToGenerateCol).End(xlDown))
        RunReplacements cel.value, CreateDocGenPath(cel.Offset(0, 1).value), oWrd
    Next cel
    oWrd.Quit
    On Error Resume Next
    'Display the folder containing the generated documents
    Call Shell("explorer.exe " & CreateDocGenPath, vbNormalFocus)
    oWrd.Quit False
    Application.StatusBar = False
    If MsgBox("Policy generation complete. The reserving information will now be recorded.", vbOKCancel, _
              "Policy Generated. OK to store reserving info?") = vbOK Then Push_Reserving_Requirements
    Exit Sub
errmsg:
    MsgBox Err.Description, , "Error generating Policy Documents"
End Sub

That routine calls RunReplacements which takes care of opening the document, prepping the environment for a fast replacement, updating links once done, handling errors, etc:

' Purpose: Opens up a document and replaces all instances of special keywords with their respective values.
'          Creates an instance of Word if an existing one is not passed as a parameter.
'          Saves a document to the target path once the template has been filled in.
'
'          Replacements are done using two helper functions, one for doing simple keyword replacements,
'          and one for the more complex replacements like conditional statements and schedules.
Private Sub RunReplacements(ByVal DocumentPath As String, ByVal SaveAsPath As String, _
                            Optional ByRef oWrd As Word.Application = Nothing)
    Dim oDoc As Word.Document
    Dim oWrdGiven As Boolean
    If oWrd Is Nothing Then Set oWrd = New Word.Application Else oWrdGiven = True

    If ERROR_HANDLING Then On Error GoTo docGenError
    oWrd.Visible = False
    oWrd.DisplayAlerts = wdAlertsNone

    Application.StatusBar = "Opening " & Mid(DocumentPath, InStrRev(DocumentPath, "") + 1)
    Set oDoc = oWrd.Documents.Open(Filename:=DocumentPath, Visible:=False)
    RunAdvancedReplacements oDoc
    RunSimpleReplacements oDoc
    UpdateLinks oDoc 'Routine which will update calculated statements in Word (like current date)
    Application.StatusBar = "Saving " & Mid(DocumentPath, InStrRev(DocumentPath, "") + 1)
    oDoc.SaveAs SaveAsPath

    GoTo Finally
docGenError:
    MsgBox "Un unknown error occurred while generating document: " & DocumentPath & vbNewLine _
            & vbNewLine & Err.Description, vbCritical, "Document Generation"
Finally:
    If Not oDoc Is Nothing Then oDoc.Close False: Set oDoc = Nothing
    If Not oWrdGiven Then oWrd.Quit False
End Sub

That routine then invokes RunSimpleReplacements. and RunAdvancedReplacements. In the former, we iterate over the set of Document Generation Keywords and call WordDocReplace if the document contains our keyword. Note that it’s much faster to try and Find a bunch of words to figure out that they don’t exist, then to call replace indiscriminately, so we always check if a keyword exists before attempting to replace it.

' Purpose: While short, this short module does most of the work with the help of the generation keywords
'          range on the lists sheet. It loops through every simple keyword that might appear in a document
'          and calls a function to have it replaced with the corresponding data from pricing.
Private Sub RunSimpleReplacements(ByRef oDoc As Word.Document)
    Dim DocGenKeys As Range, valueSrc As Range
    Dim value As String
    Dim i As Integer

    Set DocGenKeys = Lists.Range("DocumentGenerationKeywords")
    For i = 1 To DocGenKeys.Rows.Count
        If WordDocContains(oDoc, "#" & DocGenKeys.Cells(i, 1).Text & "#") Then
            'Find the text that we will be replacing the placeholder keyword with
            Set valueSrc = Range(Mid(DocGenKeys.Cells(i, 2).Formula, 2))
            If valueSrc.MergeCells Then value = valueSrc.MergeArea.Cells(1, 1).Text Else value = valueSrc.Text
            'Perform the replacement
            WordDocReplace oDoc, "#" & DocGenKeys.Cells(i, 1).Text & "#", value
        End If
    Next i
End Sub

This is the function used to detect whether a keyword exists in the document:

' Purpose: Function called for each replacement to first determine as quickly as possible whether
'          the document contains the keyword, and thus whether replacement actions must be taken.
Public Function WordDocContains(ByRef oDoc As Word.Document, ByVal searchFor As String) As Boolean
    Application.StatusBar = "Checking for keyword: " & searchFor
    WordDocContains = False
    Dim storyRange As Word.Range
    For Each storyRange In oDoc.StoryRanges
        With storyRange.Find
            .Text = searchFor
            WordDocContains = WordDocContains Or .Execute
        End With
        If WordDocContains Then Exit For
    Next
End Function

And this is where the rubber meets the road — the code that executes the replacement. This routine got more complicated as I encountered difficulties. Here are the lessons you will only learn from experience:

1. You can set the replacement text directly, or you can use the clipboard. I found out the hard way that if you are doing a VBA replace in word using a string longer than 255 characters, the text will get truncated if you try to place it in the Find.Replacement.Text, but you can use "^c" as your replacement text, and it will get it directly from the clipboard. This was the workaround I got to use.

2. Simply calling replace will miss keywords in some text areas like headers and footers. Because of this, you actually need to iterate over the document.StoryRanges and run the search and replace on each one to ensure that you catch all instances of the word you want to replace.

3. If you’re setting the Replacement.Text directly, you need to convert Excel line breaks (vbNewLine and Chr(10)) with a simple vbCr for them to appear properly in word. Otherwise, anywhere your replacement text has line breaks coming from an excel cell will end up inserting strange symbols into word. If you use the clipboard method however, you do not need to do this, as the line breaks get converted automatically when put in the clipboard.

That explains everything. Comments should be pretty clear too. Here’s the golden routine that executes the magic:

' Purpose: This function actually performs replacements using the Microsoft Word API
Public Sub WordDocReplace(ByRef oDoc As Word.Document, ByVal replaceMe As String, ByVal replaceWith As String)
    Dim clipBoard As New MSForms.DataObject
    Dim storyRange As Word.Range
    Dim tooLong As Boolean

    Application.StatusBar = "Replacing instances of keyword: " & replaceMe

    'We want to use regular search and replace if we can. It's faster and preserves the formatting that
    'the keyword being replaced held (like bold).  If the string is longer than 255 chars though, the
    'standard replace method doesn't work, and so we must use the clipboard method (^c special character),
    'which does not preserve formatting. This is alright for schedules though, which are always plain text.
    If Len(replaceWith) > 255 Then tooLong = True
    If tooLong Then
        clipBoard.SetText IIf(replaceWith = vbNullString, "", replaceWith)
        clipBoard.PutInClipboard
    Else
        'Convert excel in-cell line breaks to word line breaks. (Not necessary if using clipboard)
        replaceWith = Replace(replaceWith, vbNewLine, vbCr)
        replaceWith = Replace(replaceWith, Chr(10), vbCr)
    End If
    'Replacement must be done on multiple 'StoryRanges'. Unfortunately, simply calling replace will miss
    'keywords in some text areas like headers and footers.
    For Each storyRange In oDoc.StoryRanges
        Do
            With storyRange.Find
                .MatchWildcards = True
                .Text = replaceMe
                .Replacement.Text = IIf(tooLong, "^c", replaceWith)
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            End With
            On Error Resume Next
            Set storyRange = storyRange.NextStoryRange
            On Error GoTo 0
        Loop While Not storyRange Is Nothing
    Next
    If tooLong Then clipBoard.SetText ""
    If tooLong Then clipBoard.PutInClipboard
End Sub

When the dust settles, we’re left with a beautiful version of the initial document with production values in place of those hash marked keywords. I’d love to show an example, but of course every filled in document contain all-proprietary information.

The only think left to mention I guess would be that RunAdvancedReplacements section. It does something extremely similar — it ends up calling the same WordDocReplace function, but what’s special about the keywords used here is that they don’t link to a single cell in the original workbook, they get generated in the code-behind from lists in the workbook. So for instance, one of the advanced replacements would look like this:

'Generate the schedule of vessels
If WordDocContains(oDoc, "#VESSELSCHEDULE#") Then _
    WordDocReplace oDoc, "#VESSELSCHEDULE#", GenerateVesselSchedule()

And then there will be a corresponding routine which puts together a string containing all the vessel information as configured by the user:

' Purpose: Generates the list of vessels from the "Vessels" sheet based on the user's configuration
'          in the booking tab. The user has the option to generate one or both of Owned Vessels
'          and Chartered Vessels, as well as what fields to display. Uses a helper function.
Public Function GenerateVesselSchedule() As String
    Dim value As String

    Application.StatusBar = "Generating Schedule of Vessels."
    If Booking.Range("ListVessels").value = "Yes" Then
        Dim VesselCount As Long

        If Booking.Range("ListVessels").Offset(1).value = "Yes" Then _
            value = value & GenerateVesselScheduleHelper("Vessels", VesselCount)
        If Booking.Range("ListVessels").Offset(1).value = "Yes" And _
           Booking.Range("ListVessels").Offset(2).value = "Yes" Then _
            value = value & "(Chartered Vessels)" & vbNewLine
        If Booking.Range("ListVessels").Offset(2).value = "Yes" Then _
            value = value & GenerateVesselScheduleHelper("CharteredVessels", VesselCount)
        If Len(value) > 2 Then value = Left(value, Len(value) - 2) 'Remove the trailing line break
    Else
        GenerateVesselSchedule = Booking.Range("VesselSchedAlternateText").Text
    End If
    GenerateVesselSchedule = value
End Function

' Purpose: Helper function for the Vessel Schedule generation routine. Generates either the Owned or
'          Chartered vessels based on the schedule parameter passed. The list is numbered and contains
'          the information selected by the user on the Booking sheet.
' SENSITIVE: Note that this routine is sensitive to the layout of the Vessel Schedule tab and the
'            parameters on the Configure Quotes tab. If either changes, it should be revisited.
Public Function GenerateVesselScheduleHelper(ByVal schedule As String, ByRef VesselCount As Long) As String
    Dim value As String, nextline As String
    Dim numInfo As Long, iRow As Long, iCol As Long
    Dim Inclusions() As Boolean, Columns() As Long

    'Gather info about vessel info to display in the schedule
    With Booking.Range("VesselInfoToInclude")
        numInfo = Booking.Range(.Cells(1, 1), .End(xlToRight)).Columns.Count - 1
        ReDim Inclusions(1 To numInfo)
        ReDim Columns(1 To numInfo)
        On Error Resume Next 'Some columns won't be identified
        For iCol = 1 To numInfo
            Inclusions(iCol) = .Offset(0, iCol) = "Yes"
            Columns(iCol) = sumSchedVessels.Range(schedule).Cells(1).EntireRow.Find(.Offset(-1, iCol)).Column
        Next iCol
        On Error GoTo 0
    End With

    'Build the schedule
    With sumSchedVessels.Range(schedule)
        For iRow = .row + 1 To .row + .Rows.Count - 1
            If Len(sumSchedVessels.Cells(iRow, Columns(1)).value) > 0 Then
                VesselCount = VesselCount + 1
                value = value & VesselCount & "." & vbTab
                nextline = vbNullString
                'Add each property that was included to the description string
                If Inclusions(1) Then nextline = nextline & sumSchedVessels.Cells(iRow, Columns(1)) & vbTab
                If Inclusions(2) Then nextline = nextline & "Built: " & sumSchedVessels.Cells(iRow, Columns(2)) & vbTab
                If Inclusions(3) Then nextline = nextline & "Length: " & _
                                      Format(sumSchedVessels.Cells(iRow, Columns(3)), "#'") & vbTab
                If Inclusions(4) Then nextline = nextline & "" & sumSchedVessels.Cells(iRow, Columns(4)) & vbTab
                If Inclusions(5) Then nextline = nextline & "Hull Value: " & _
                                      Format(sumSchedVessels.Cells(iRow, Columns(5)), "$#,##0") & vbTab
                If Inclusions(6) Then nextline = nextline & "IV: " & _
                                      Format(sumSchedVessels.Cells(iRow, Columns(6)), "$#,##0") & vbTab
                If Inclusions(7) Then nextline = nextline & "TIV: " & _
                                      Format(sumSchedVessels.Cells(iRow, Columns(7)), "$#,##0") & vbTab
                If Inclusions(8) And schedule = "CharteredVessels" Then _
                    nextline = nextline & "Deductible: " & Format(bmCharterers.Range(schedule).Cells( _
                               iRow - .row, 9), "$#,##0") & vbTab
                nextline = Left(nextline, Len(nextline) - 1) 'Remove the trailing tab
                'If more than 4 properties were included insert a new line after the 4th one
                Dim tabloc As Long: tabloc = 0
                Dim counter As Long: counter = 0
                Do
                    tabloc = tabloc + 1
                    tabloc = InStr(tabloc, nextline, vbTab)
                    If tabloc > 0 Then counter = counter + 1
                Loop While tabloc > 0 And counter < 4
                If counter = 4 Then nextline = Left(nextline, tabloc - 1) & vbNewLine & Mid(nextline, tabloc)
                value = value & nextline & vbNewLine
            End If
        Next iRow
    End With

    GenerateVesselScheduleHelper = value
End Function

the resulting string can be used just like the contents of any excel cell, and passed to the replacement function, which will appropriately use the clipboard method if it exceeds 255 characters.

So this template:

Plus this spreadsheet data:

Becomes this document:

I sincerely hope that this helps someone out some day. It was definitely a huge undertaking and a complex wheel to have to re-invent. The application is huge, with over 50,000 lines of VBA code, so if I’ve referenced a crucial method in my code somewhere that someone needs, please leave a comment and I’ll add it in here.