Excel VBA Code Fails Inconsistently When Trying to Copy/Paste Strings from MSWord to MSExcel

Question

I am trying to write a VBA code that will search a word document for certain strings and copy and paste them to an Excel file. When I run the code, it will inconsistently bug out at the line "EDS.Sheets("Monthly Usage").Range("A" & N:).PasteSpecial Paste:=xlPasteValues". It will sometimes not paste anything at all, only a percentage of the account numbers in question, or everything perfectly. The errors can be one of a couple: Error 1004: PasteSpecial method out of Range class failed or "Run-time error '-2147221036 (800401d4)' DataObject:PutInClipboard CloseClipboard Failed"

I have tried resetting the Clipboard each loop, and as I do not know any VBA coding that well, I tried finding an alternative solution to copy the variable but could not find anything concrete.

Sub Work()
    Dim c As Range
    Dim startword As String
    Dim refnumber As String
    Dim WD As Object
    Dim ED As Object
    Dim EDS As Object
    Dim myData As Object
    Set WD = ActiveDocument
    Set ED = CreateObject("excel.application")
    ED.Visible = True
    Set EDS = ED.Workbooks.Open(FileName:="\\Ecdccesms01\bu\CES\Choice\Operations\Transactions\SOCAL\Manual Usage Files\Loads\2019\April 2019\Test.xlsm")
    Dim N  As Integer
    N = 2

    startword = "ACCOUNT#:                    "
    Set c = ActiveDocument.Content

    c.Find.ClearFormatting
    c.Find.Replacement.ClearFormatting

    With c.Find
        .Text = startword & "[A-Z0-9]{10}"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True


        Do Until Not .Execute()
            refnumber = Right(c.Text, 10)
            Set myData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            myData.SetText refnumber
            myData.PutInClipboard
            EDS.Sheets("Monthly Usage").Range("A" & N).PasteSpecial Paste:=xlPasteValues
            N = N + 1
            Set myData = Nothing
        Loop

    End With

    N = 2
    startword1 = "FROM: "
    Set c = ActiveDocument.Content
    Set myData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    c.Find.ClearFormatting
    c.Find.Replacement.ClearFormatting

    With c.Find
        .Text = startword1 & "[A-Z0-9/]{8}"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True


        Do Until Not .Execute()
            refnumber = Right(c.Text, 8)
            Set myData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            myData.SetText refnumber
            myData.PutInClipboard
            EDS.Sheets("Monthly Usage").Range("B" & N).PasteSpecial Paste:=xlPasteValues
            N = N + 1
            Set myData = Nothing
        Loop

    End With

    N = 2
    startword2 = "TO: "
    Set c = ActiveDocument.Content
    Set myData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    c.Find.ClearFormatting
    c.Find.Replacement.ClearFormatting

    With c.Find
        .Text = startword2 & "[A-Z0-9/]{8}"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True


        Do Until Not .Execute()
            refnumber = Right(c.Text, 8)
            Set myData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            myData.SetText refnumber
            myData.PutInClipboard
            EDS.Sheets("Monthly Usage").Range("c" & N).PasteSpecial Paste:=xlPasteValues
            N = N + 1
            Set myData = Nothing
        Loop

    End With
End Sub

Tim Williams Tim Williams · Accepted Answer · 2019-04-24T18:58:28

Why do this:

refnumber = Right(c.Text, 10)
Set myData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
myData.SetText refnumber
myData.PutInClipboard
EDS.Sheets("Monthly Usage").Range("A" & N).PasteSpecial Paste:=xlPasteValues

and not this:

EDS.Sheets("Monthly Usage").Range("A" & N).Value = Right(c.Text, 10)

?

PS - do yourself a favor and abstract out the repeated parts of your code.

Untested, but you get the idea:

Sub Work()

    Dim WD As Object
    Dim ED As Object
    Dim EDS As Object, EDSSheet As Object

    Set WD = ActiveDocument
    Set ED = CreateObject("excel.application")
    ED.Visible = True
    Set EDS = ED.Workbooks.Open(FileName:="\\Ecdccesms01\bu\CES\Choice\Operations\Transactions\SOCAL\Manual Usage Files\Loads\2019\April 2019\Test.xlsm")
    Set EDSSheet = EDS.Sheets("Monthly Usage")

    CopyHits WD, "ACCOUNT#:", 10, EDSSheet.Range("A2")
    CopyHits WD, "FROM: ", 8, EDSSheet.Range("B2")
    CopyHits WD, "TO: ", 8, EDSSheet.Range("C2")

End Sub

Sub CopyHits(doc As Document, findWhat As String, numChars As Long, copyTo As Object)
    Dim c As Range
    Set c = doc.Content
    With c.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = findWhat & "[A-Z0-9]{" & numChars & "}"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        Do Until Not .Execute()
            copyTo.Value = Right(c.Text, numChars)
            Set copyTo = copyTo.Offset(1, 0) '<< move to next cell down
        Loop
    End With
End Sub

Excel VBA Code Fails Inconsistently When Trying to Copy/Paste Strings from MSWord to MSExcel

1 Answers