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

Posted 2023-05-06

【中文标题】尝试将字符串从 MS Word 复制/粘贴到 MS Excel 时，Excel VBA 代码失败不一致

【英文标题】：Excel VBA Code Fails Inconsistently When Trying to Copy/Paste Strings from MSWord to MSExcel

【发布时间】：2019-04-24 18:46:04

【问题描述】：

我正在尝试编写一个 VBA 代码，该代码将在 word 文档中搜索某些字符串并将它们复制并粘贴到 Excel 文件中。当我运行代码时，它会在“EDS.Sheets(“Monthly Usage”).Range(“A”& N:).PasteSpecial Paste:=xlPasteValues”行不一致地出错。它有时根本不会粘贴任何东西，只会粘贴一定比例的相关帐号，或者完美无缺。错误可能是以下几个之一： 错误 1004：PasteSpecial 方法超出 Range 类失败或“运行时错误 '-2147221036 (800401d4)' DataObject:PutInClipboard CloseClipboard 失败"

我已尝试在每个循环中重置剪贴板，但由于我不太了解任何 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:="\\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

【参考方案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:="\\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

【讨论】：

因为我是个白痴，但你刚刚救了我。谢谢你，好先生。我专注于复制/粘贴方面，甚至没有想到将单元格值设置为等于找到的字符串。