Блог

Я пытаюсь написать код VBA, который будет искать в документе word определенные строки и копировать и вставлять их в файл Excel. Когда я запускаю код, он непоследовательно выдает ошибку в строке «EDS.Sheets («Ежемесячное использование»).Диапазон («A» amp; N:).Вставьте специальную вставку:=xlPasteValues». Иногда он вообще ничего не вставляет, только процент от номеров учетных записей, о которых идет речь, или все идеально. Ошибки могут быть одной из пары: Ошибка 1004: ошибка вставленного специального метода вне диапазона class или «Ошибка времени выполнения» -2147221036 (800401d4) «Объект данных: ошибка закрытия PutInClipboard»

Я пробовал сбрасывать буфер обмена в каждом цикле, и поскольку я не настолько хорошо знаю кодировку 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 amp; "[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" amp; 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 amp; "[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" amp; 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 amp; "[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" amp; N).PasteSpecial Paste:=xlPasteValues
            N = N   1
            Set myData = Nothing
        Loop

    End With
End Sub
  

Зачем это делать:

 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" amp; N).PasteSpecial Paste:=xlPasteValues
  

и не это:

 EDS.Sheets("Monthly Usage").Range("A" amp; 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 amp; "[A-Z0-9]{" amp; numChars amp; "}"
        .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