Creating Word Docs w/ Excel VBA- Insert Images? Copy and Paste Text from 3rd Doc

Question

I am trying to write some VBA code in excel to automate my task of building 100+ .pdf word documents, each following the set template. I originally copied a code from a youtube tutorial showing how to build automated emails from a spreadsheet, and I felt my application was similar enough.

I can get the text replacements to occur as they should. My primary issue is getting images inserted where they need to be. I've attempted using a bookmark and replace code with no luck. I think my issue lies in my variables not having the correct value between the various subs, although that is only my uneducated best guess.

My next issue is creating a code to pull text from an existing document and paste into a new document. I'll be honest, I have been so stuck on the image issue that I haven't even looked into this yet.

I may be going about this task in an inefficient way, however, if someone may be able to spot the fault in my code, it would be greatly appreciated. I have pasted my existing code below. Hopefully it isn't too bad.

    Option Explicit

   Dim CustRow, CustCol, LastRow, TemplRow, j  As Long
   Dim DocLoc, TagName, TagValue, TemplName, FileName As String
   Dim CurDt, LastAppDt As Date
   Dim WordDoc, WordApp As Object
   Dim WordContent As Word.Range

Sub CreateWordDocuments()

With Sheet1

  If .Range("B3").Value = Empty Then
    MsgBox "Please select a correct template from the drop down list"
    .Range("G3").Select
    Exit Sub
  End If
    TemplRow = .Range("B3").Value 'Set Template Row
    TemplName = .Range("G3").Value 'Set Template Name
    DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename

    'Open Word Template
    On Error Resume Next 'If Word is already running
    Set WordApp = GetObject("Word.Application")
        If Err.Number <> 0 Then
        'Launch a new instance of Word
        Err.Clear
        'On Error GoTo Error_Handler
        Set WordApp = CreateObject("Word.Application")
        WordApp.Visible = True 'Make the application visible to the user
        End If


    LastRow = .Range("E9999").End(xlUp).Row  'Determine Last Row in Table
        For CustRow = 8 To LastRow
                                Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
                                For CustCol = 5 To 10 'Move Through 6 Columns
                                    TagName = .Cells(7, CustCol).Value 'Tag Name
                                    TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
                                     With WordDoc.Content.Find
                                        .Text = TagName
                                        .Replacement.Text = TagValue
                                        .Wrap = wdFindContinue
                                        .Execute Replace:=wdReplaceAll 'Find & Replace all instances
                                     End With
                                 Next CustCol

         Call InsertScreenshots

    If .Range("I3").Value = "PDF" Then
                                          FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Category_Model
                                          WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
                                          WordDoc.Close False
                                      Else: 'If Word
                                          FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
                                          WordDoc.SaveAs FileName
                                   End If
                                      .Range("O" & CustRow).Value = TemplName 'Template Name
                                      .Range("P" & CustRow).Value = Now
     Next CustRow


End With


End Sub


 Sub FillABookmark(bookmarkname As String, imagepath As String)

   Dim objWord As Object
    Dim objDoc As Object
    With Sheet1

    On Error Resume Next
    Set objWord = GetObject(, "Word.Application")
    If objWord Is Nothing Then
        Set objWord = CreateObject("Word.Application")
        objWord.Visible = True
        objWord.Documents.Open "DocLoc"
    End If

    Set objDoc = objWord.ActiveDocument

    With objDoc
        .Bookmarks(bookmarkname).Select
        .Shapes.AddPicture FileName:=imagepath
    End With
End With
End Sub

Sub InsertScreenshots()
    With Sheet1
        For CustCol = 11 To 14 'Move Through 4 Columns
            TagName = .Cells(7, CustCol).Value 'Tag Name
            TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
                    Call FillABookmark("TagName", "TagValue")
         Next CustCol
    End With

End Sub

chris neilsen chris neilsen · Accepted Answer · 2018-08-01T00:55:25

There is a lot going on here and a lot of issues.

Key Points

Learn the value of proper indenting
Dim all variables, otherwise they will be Variants
Early Binding is easier to debug. Use explicit types rather than Object
Don't use Module scoped Variables unless you have a good reason
CodeNames can be useful, but give them meaningful names
Correct test for Empty is IsEmpty
GetObject ClassID is the 2nd parameter. I needed to use Word.Application.16, your installation may vary
Reset your error handling after using On Error Resume Next as soon as you can (this likely was hiding errors from you)
When using EndUp to find the last used row, search from the bottom of the sheet
Simplified the calling of your InsertScreenshots code
You already had a Word app and open doc, don't open it again
Simplified the Insert of image, avoid use of Select

Note: without a sample of your workbook and word doc I can't be sure there aren't other issues, you will need to continue the debug.

See inline comments on changes marked with ~~

Refactored code

Option Explicit

Sub CreateWordDocuments()
    '~~ Don't use module scoped variables
    '~~ declare all variable types, else they are Variants
    Dim CustRow As Long, CustCol As Long, LastRow As Long, TemplRow As Long, j As Long 
    Dim DocLoc As String, TagName As String, TagValue As String, TemplName As String, FileName As String
    Dim CurDt As Date, LastAppDt As Date
        '~~ to make debugging easier, use Early Binding (add reference to Microsoft Word), to get Intellisence help.  If you need late binding, change back later
    Dim WordDoc As Word.Document, WordApp As Word.Application    '  Object
    Dim WordContent As Word.Range '~~ this suggests you are already using Early Binding!

    With Sheet1 '~~ If you are going to use CodeNames, give the sheet a meaningful name (edit it in the Properties window)
        If IsEmpty(.Range("B3").Value) Then  '~~ correct test for Empty
            MsgBox "Please select a correct template from the drop down list"
            .Range("G3").Select '~~ will only work if Sheet1 is active
            Exit Sub
        End If
        TemplRow = .Range("B3").Value 'Set Template Row
        TemplName = .Range("G3").Value 'Set Template Name
        DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename

        'Open Word Template
        On Error Resume Next 'If Word is already running
        Set WordApp = GetObject(, "Word.Application.16") '~~ correct format for Office365 - YMMV
        If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo 0 '~~ reset error handling
            'Launch a new instance of Word
            Set WordApp = New Word.Application ' CreateObject("Word.Application")
            WordApp.Visible = True 'Make the application visible to the user
        End If
        On Error GoTo 0 '~~ reset error handling
        WordApp.Visible = True
        LastRow = .Cells(.Rows.Count, 5).End(xlUp).Row '~~ use real last row  'Determine Last Row in Table
        For CustRow = 8 To LastRow
            Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
            For CustCol = 5 To 10 'Move Through 6 Columns
                TagName = .Cells(7, CustCol).Value 'Tag Name
                TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
                With WordDoc.Content.Find
                   .Text = TagName
                   .Replacement.Text = TagValue
                   .Wrap = wdFindContinue
                   .Execute Replace:=wdReplaceAll 'Find & Replace all instances
                End With
            Next CustCol
            For CustCol = 11 To 14 'Move Through 4 Columns  ~~ do it here, it's cleaner and easier to reference the Row
                TagName = .Cells(7, CustCol).Value '~~ Bookmark Name
                TagValue = .Cells(CustRow, CustCol).Value '~~ Image path and name
                FillABookmark TagName, TagValue, WordDoc '~~ call to insert each image
            Next

            If .Range("I3").Value = "PDF" Then
                FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Category_Model
                WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
                WordDoc.Close False
            Else '~~ don't need the : 
                FileName = ThisWorkbook.Path & "\" & .Range("E" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
                WordDoc.SaveAs FileName
            End If
            .Range("O" & CustRow).Value = TemplName 'Template Name
            .Range("P" & CustRow).Value = Now
         Next CustRow
    End With
End Sub


Sub FillABookmark(bookmarkname As String, imagepath As String, objDoc As Word.Document)
    '~~ Use passed Parameter for Doc
    '~~ Don't need select
    objDoc.Bookmarks(bookmarkname).Range _
        .InlineShapes.AddPicture FileName:=imagepath
End Sub

Creating Word Docs w/ Excel VBA- Insert Images? Copy and Paste Text from 3rd Doc

1 Answers