Excel VBA Errors when trying to copy and paste objects from Excel to Word

C

Chris Tomz

New Member
Joined
Jul 22, 2020
Messages
3
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hello All,

I have some VBA code that I need help refining. The problem I am having is inconsistent and unexplained 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:

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.

VBA Code: 
      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
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Sort by date Sort by votes
Hi,

Try this version of CopyPasteImage2 code:
VBA Code: 
Sub CopyPasteImage2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)
  
  Const AttemptsMax = 10  ' Increase this constant if Error MsgBox appears
  Dim Attempt As Long
  
  With oDoc
    
    .Activate
    .ActiveWindow.View = wdNormalView
    
    Application.CutCopyMode = False
    
    On Error GoTo ErrHandler
    
    Attempt = 1
    Wks.Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("CompanyLogo").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
  
    Attempt = 1
    Wks.Range("N11:O15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ConsulSig").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
  
    Attempt = 1
    Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ClientSig").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
  
    Attempt = 1
    Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ClientSig2").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
  
    .Save
  
    If boolCloseAfterExec Then
      oDoc.Close
      oDoc.Parent.Quit
    End If
  
  End With
  
ErrHandler:
  
  If Attempt < AttemptsMax Then
    Attempt = Attempt + 1
    Application.CutCopyMode = False
    DoEvents
    DoEvents
    Resume  ' this returns execution of the errored line again
  Else
    MsgBox Err.Description, vbExclamation, "Error at Attempt = " & Attempt
  End If
  
End Sub
 
Upvote 0
Thanks Vladimir,

I tried the code below and even increased the constant as suggested (max 50) but the "resume without error" message keeps popping up and interrupting the run all function.

Any other ideas how to solve this issue?


ZVI said:
Hi,

Try this version of CopyPasteImage2 code:
VBA Code: 
Sub CopyPasteImage2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)
 
  Const AttemptsMax = 10  ' Increase this constant if Error MsgBox appears
  Dim Attempt As Long
 
  With oDoc
   
    .Activate
    .ActiveWindow.View = wdNormalView
   
    Application.CutCopyMode = False
   
    On Error GoTo ErrHandler
   
    Attempt = 1
    Wks.Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("CompanyLogo").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
 
    Attempt = 1
    Wks.Range("N11:O15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ConsulSig").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
 
    Attempt = 1
    Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ClientSig").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
 
    Attempt = 1
    Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ClientSig2").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
 
    .Save
 
    If boolCloseAfterExec Then
      oDoc.Close
      oDoc.Parent.Quit
    End If
 
  End With
 
ErrHandler:
 
  If Attempt < AttemptsMax Then
    Attempt = Attempt + 1
    Application.CutCopyMode = False
    DoEvents
    DoEvents
    Resume  ' this returns execution of the errored line again
  Else
    MsgBox Err.Description, vbExclamation, "Error at Attempt = " & Attempt
  End If
 
End Sub
Click to expand...
 
Upvote 0
Chris, this should work :)
Code:
Rich (BB code): 
Option Explicit
'https://www.mrexcel.com/board/threads/.1140894/post-5528899

#If VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
  Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr
#Else
  Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
  Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
  Private Declare Function CloseClipboard Lib "user32.dll" () As Long
#End If

Sub Full_policy_document()
  ' As is
End Sub

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

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

  Dim oWord As Word.Application

  On Error GoTo exit_
  Set oWord = oDoc.Application
  oWord.ScreenUpdating = False
  With oDoc
    Application.CutCopyMode = False
    If PictureToBookmark(Wks.Range("K2:L15"), .Bookmarks("CompanyLogo")) = False Then Exit Sub
    If PictureToBookmark(Wks.Range("N02:O07"), .Bookmarks("ClientSig")) = False Then Exit Sub
    If PictureToBookmark(Wks.Range("N02:O07"), .Bookmarks("ClientSig2")) = False Then Exit Sub
    .Save
  End With

  If boolCloseAfterExec Then
    oDoc.Close
    oWord.Quit
    Set oDoc = Nothing
    Set oWord = Nothing
  End If

exit_:

  If Not oWord Is Nothing Then oWord.ScreenUpdating = True

  If Err Then
    MsgBox Err.Description, vbExclamation, "CopyPasteImage2 Error #" & Err.Number
  End If

End Sub

Function PictureToBookmark(oRng As Range, ByVal oBmk As Word.Bookmark) As Boolean
  Const TIMEOUT As Single = 0.1
  #If VBA7 Then
    Dim hMem As LongPtr
    Dim dwBytes As LongPtr
    Dim lpData As LongPtr
  #Else
    Dim hMem As Long
    Dim dwBytes As Long
    Dim lpData As Long
  #End If
  Dim t As Single
  Dim sBmkNm As String
  Dim oBmkRng As Word.Range

  On Error GoTo exit_
  sBmkNm = oBmk.Name
  Set oBmkRng = oBmk.Range

  ' Empty Clipboard
  Application.CutCopyMode = False
  t = Timer + TIMEOUT
  While Timer <= t
    DoEvents
    If OpenClipboard(0) <> 0 Then t = 0
  Wend
  If t <> 0 Then
    MsgBox "Can't open Clipboard" & vbLf _
            & "Try hitting Win-V and clean a Clipboard buffer", _
            vbCritical, "Open Clipboard Error"
    Exit Function
  End If
  EmptyClipboard
  DoEvents
  CloseClipboard
  DoEvents

  ' Copy range as Picture
  On Error Resume Next
  t = Timer + TIMEOUT
  While Timer <= t
    DoEvents
    Err.Clear
    oRng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    If Err.Number = 0 Then t = 0
  Wend
  If t <> 0 Then
    MsgBox "Can't copy " & oRng.Address(0, 0) & " as Pictire." & vbLf _
            & "Try hitting Win-V and clean a Clipboard buffer", _
            vbCritical, "Copy Picture Error"
    Exit Function
  End If

  ' Paste Picture into Bookmark range
  oBmkRng.Paste
  oBmkRng.Parent.Bookmarks.Add sBmkNm, oBmkRng
  oBmkRng.InsertParagraph

  ' Return Ok
  PictureToBookmark = True

exit_:

  Application.CutCopyMode = False
  DoEvents

  Set oBmkRng = Nothing

  If Err Then
    MsgBox Err.Description, vbCritical, "PictureToBookmark Error #" & Err.Number
  End If

End Function
Regards
 
Last edited:
Upvote 0
Thanks Vladimir,

I implemented the code and it works great.

Experienced one error but it was much easier to resolve and continue the process.

Really appreciate the assistance :)

ZVI said:
Chris, this should work :)
Code:
Rich (BB code): 
Option Explicit
'https://www.mrexcel.com/board/threads/.1140894/post-5528899

#If VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
  Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr
#Else
  Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
  Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
  Private Declare Function CloseClipboard Lib "user32.dll" () As Long
#End If

Sub Full_policy_document()
  ' As is
End Sub

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

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

  Dim oWord As Word.Application

  On Error GoTo exit_
  Set oWord = oDoc.Application
  oWord.ScreenUpdating = False
  With oDoc
    Application.CutCopyMode = False
    If PictureToBookmark(Wks.Range("K2:L15"), .Bookmarks("CompanyLogo")) = False Then Exit Sub
    If PictureToBookmark(Wks.Range("N02:O07"), .Bookmarks("ClientSig")) = False Then Exit Sub
    If PictureToBookmark(Wks.Range("N02:O07"), .Bookmarks("ClientSig2")) = False Then Exit Sub
    .Save
  End With

  If boolCloseAfterExec Then
    oDoc.Close
    oWord.Quit
    Set oDoc = Nothing
    Set oWord = Nothing
  End If

exit_:

  If Not oWord Is Nothing Then oWord.ScreenUpdating = True

  If Err Then
    MsgBox Err.Description, vbExclamation, "CopyPasteImage2 Error #" & Err.Number
  End If

End Sub

Function PictureToBookmark(oRng As Range, ByVal oBmk As Word.Bookmark) As Boolean
  Const TIMEOUT As Single = 0.1
  #If VBA7 Then
    Dim hMem As LongPtr
    Dim dwBytes As LongPtr
    Dim lpData As LongPtr
  #Else
    Dim hMem As Long
    Dim dwBytes As Long
    Dim lpData As Long
  #End If
  Dim t As Single
  Dim sBmkNm As String
  Dim oBmkRng As Word.Range

  On Error GoTo exit_
  sBmkNm = oBmk.Name
  Set oBmkRng = oBmk.Range

  ' Empty Clipboard
  Application.CutCopyMode = False
  t = Timer + TIMEOUT
  While Timer <= t
    DoEvents
    If OpenClipboard(0) <> 0 Then t = 0
  Wend
  If t <> 0 Then
    MsgBox "Can't open Clipboard" & vbLf _
            & "Try hitting Win-V and clean a Clipboard buffer", _
            vbCritical, "Open Clipboard Error"
    Exit Function
  End If
  EmptyClipboard
  DoEvents
  CloseClipboard
  DoEvents

  ' Copy range as Picture
  On Error Resume Next
  t = Timer + TIMEOUT
  While Timer <= t
    DoEvents
    Err.Clear
    oRng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    If Err.Number = 0 Then t = 0
  Wend
  If t <> 0 Then
    MsgBox "Can't copy " & oRng.Address(0, 0) & " as Pictire." & vbLf _
            & "Try hitting Win-V and clean a Clipboard buffer", _
            vbCritical, "Copy Picture Error"
    Exit Function
  End If

  ' Paste Picture into Bookmark range
  oBmkRng.Paste
  oBmkRng.Parent.Bookmarks.Add sBmkNm, oBmkRng
  oBmkRng.InsertParagraph

  ' Return Ok
  PictureToBookmark = True

exit_:

  Application.CutCopyMode = False
  DoEvents

  Set oBmkRng = Nothing

  If Err Then
    MsgBox Err.Description, vbCritical, "PictureToBookmark Error #" & Err.Number
  End If

End Function
Regards
Click to expand...
 
Upvote 0
Chris, thank you for confirming it works for you!
?:)
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question Question
Runtime Error 462 when Running Code to Export Excel Values into Word Bookmarks
Replies
6
Views
1K
pastelprincess
P
T
  • Question Question
Launch new Word doc from Excel not working on Mac
Replies
0
Views
649
tykoom
T
H
  • Question Question
VBA - Delete and insert bookmark text in same word document based on excel cell values
Replies
0
Views
2K
HH7
H
A
  • Solved
VBA Error: Compile Error: Method or Data Member not found. When Pasting Excel Data into Word
Replies
3
Views
2K
RoryA
RoryA
P
  • Question Question
Copy two tables from Excel and insert in Word
Replies
0
Views
559
perola.rike
P

Forum statistics

Threads
1,224,818
Messages
6,181,152
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top