Question

我正在尝试编写一个VBA代码，该代码将在Word文档中搜索某些字符串并将其复制并粘贴到Excel文件中。当我运行代码时，它会不一致地在“ EDS.Sheets（“每月使用情况”）.Range（“ A”和N :)。PasteSpecial Paste：= xlPasteValues“行中出错。有时它根本不会粘贴任何东西，只会粘贴一定比例的问题编号，或者完美地粘贴所有内容。错误可能是以下之一：错误1004：超出范围类的PasteSpecial方法失败或“运行时错误'-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

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:="\\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

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

1 个答案: