尝试将字符串从 MSWord 复制/粘贴到 MSExcel 时，Excel VBA 代码失败不一致

Question

我正在尝试编写一个VBA代码，该代码将在word文档中搜索某些字符串并将它们复制并粘贴到Excel文件中。当我运行代码时，它会不一致地出现在"EDS.表("每月使用量"(。范围("A"和N：(。PasteSpecial Paste：=xlPasteValues"。它有时根本不会粘贴任何内容，只会粘贴相关帐号的百分比，或者完美地粘贴所有内容。错误可能是以下几个错误之一：错误 1004：PasteSpecial 方法超出范围类失败或"运行时错误'-2147221036 (800401d4("数据对象：放入剪贴板关闭剪贴板失败">

我尝试重置每个循环的剪贴板，由于我对任何 VBA 编码都不太了解，我尝试找到一种替代解决方案来复制变量，但找不到任何具体的东西。

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:="\Ecdccesms01buCESChoiceOperationsTransactionsSOCALManual Usage FilesLoads2019April 2019Test.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

Answer 1

为什么要这样做：

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

而不是这个：

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

？

PS - 帮自己一个忙，抽象出代码的重复部分。

未经测试，但你明白了：

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:="\Ecdccesms01buCESChoiceOperationsTransactionsSOCALManual Usage FilesLoads2019April 2019Test.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