Hello All,

I have some VBA code that I need help refining. The problem I am having is inconsistent errors, from my research it appears that the issue is with the clipboard crashing.

How the VBA code works:

I have an embedded Word documents with various bookmarks and reference texts. The bookmarks correspond to named ranges in the Excel workbook. My VBA code opens the embedded Word document, copies the various named ranges in the Excel workbook and pastes the content of the clipboard at the appropriate bookmark in the Word document.

I have a RUN ALL macro set up to create multiple word documents, but it crashes constantly during this process.

I’ve research how to fix this and may have found the answer (Do Loop to retry the copy/paste operation) but as I am very new to VBA I’m not sure how to implement it into my code.

Would greatly appreciate any help with this.


Here is my VBA code:

Sub Full_policy_document()

    Dim wdApp       As Word.Application
    Dim Wks         As Excel.Worksheet
    Dim wddoc       As Word.Document

    Set Wks = ActiveSheet

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False

    Set wddoc = wdApp.Documents.Open(Environ("UserProfile") & "\Google Drive\SMS TEMPLATES\01 POLICIES\001 H&S Full Policy Document.docx")

    Call ReplaceWords2(wddoc, Wks, False)
    Call CopyPasteImage2(wddoc, Wks, False) 'switch back to true
    wdApp.Quit
    

    Set wddoc = Nothing
    Set wdApp = Nothing

End Sub



Sub ReplaceWords2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)

    Dim wdRng       As Word.Range
    Dim varTxt      As Variant
    Dim varRngAddress As Variant
    Dim i           As Long

varTxt = Split("cp1,na1,po2,id1,rd1,bd1,an1,ns1,ct1,bc1,pt1,vd1,me1,mc1,po1", ",")
    varRngAddress = Split("C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17", ",")

    For Each wdRng In oDoc.StoryRanges

        With wdRng.Find
            For i = 0 To UBound(varTxt)
                .Text = varTxt(i)
                .Replacement.Text = Wks.Range(varRngAddress(i)).Value
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            Next i
        End With

    Next wdRng

    oDoc.SaveAs2 Environ("UserProfile") & "\desktop\001 H&S Full Policy Document"
    If boolCloseAfterExec Then
        oDoc.Close
        oDoc.Parent.Quit
    End If

End Sub



Sub CopyPasteImage2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)

    With oDoc
        .Activate

        .ActiveWindow.View = wdNormalView
        Wks.Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("CompanyLogo").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph

        Wks.Range("N11:O15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("ConsulSig").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph
        
        Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("ClientSig").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph
        
         Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("ClientSig2").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph

        .Save

        If boolCloseAfterExec Then
        oDoc.Close
        oDoc.Parent.Quit
        End If
        
    End With
End Sub
Here is the code I need help implementing.

      On Error GoTo 0  ' Normal error handling
      Application.CutCopyMode = False   ' Clear clipboard before copy
      Range(excel_range_name).CopyPicture
      n = 1 ' Set counter to 1
      Do Until n > 3 'Attempt paste function three times before falling out
            If n < 3 Then  ' suspend normal error handling
                On Error Resume Next
            Else
                 On Error GoTo 0 ' on last attempt, reinstate normal error handling
            End If
            newWord.Bookmarks(bookmark_name).Range.Characters.Last.Paste   ' Paste into Word
            If Err.Number = 0 Then
                  On Error GoTo 0 'reinstate normal error handling
                  Exit Do   ' Exit if no error encountered
            End If
            n = n + 1  ' Increment counter and repeat the Do Until Loop
            DoEvents
      Loop
       On Error GoTo 0  ' Just to make sure that normal error handling is reinstated