错误 1004 工作表类的粘贴方法失败，间歇性

Question

此代码的目的是从 Word 文档中搜索数字并将其复制到 Excel 电子表格中。它不会一直发生，但是当我运行此脚本时，我会不时收到 1004 错误。调试器将“Do While Loop”下的first“ActiveSheet.Paste”语句突出显示为代码问题。我没有看到与脚本的任何其他部分有任何冲突。有人发现有什么不对吗？

Sub TorCopy()

    ' Set variables
    Dim Word As New Word.Application
    Dim WordDoc As New Word.Document
    Dim i As Integer
    Dim j As Integer
    Dim r As Word.range
    Dim Doc_Path As String
    Dim TOR_Tracker As Excel.Workbook
    Dim TOR_Tracker_Path As String
    Dim Whiteboard_Path As String
    Dim Whiteboard As Excel.Workbook
    Dim n As Integer

    ' Set File Path that contains TOR
    ' Open File
    Doc_Path = "C:\Word_File.doc"
    Set WordDoc = Word.Documents.Open(Doc_Path)

    TOR_Tracker_Path = "C:\Tracker_Spreadsheet.xlsm"
    Set TOR_Tracker = Workbooks.Open(TOR_Tracker_Path)

    Whiteboard_Path = "C:\Excel_Spreadsheet_Acting_As_A_Whiteboard.xlsm"
    Set Whiteboard = Workbooks.Open(Whiteboard_Path)

    Whiteboard.Worksheets("Sheet1").Activate

    ' Create a range to search
    Set r = WordDoc.Content

    j = 1

    ' Find TOR numbers and copy them to whiteboard spreadsheet
    With r
        .Find.ClearFormatting
        With .Find
            .Text = "TP[0-9]{4}"
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = True
        End With
        Do While .Find.Execute = True
            .Copy
            ActiveSheet.Cells(j, 1).Select
            ActiveSheet.Paste
            j = j + 1
        Loop
    End With

    ' Filter out duplicate TOR numbers
    n = Cells(Rows.Count, "A").End(xlUp).Row
    ActiveSheet.range("A1:A" & n).RemoveDuplicates Columns:=1, Header:=xlNo

    ' Copy TOR numbers from whiteboard
    With ActiveSheet
        .range("A1").Select
        .range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
    End With

    ' Paste to TOR Tracker
    TOR_Tracker.Worksheets("Sheet1").Activate
    With ActiveSheet
        .range("A1").Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(1, 4).Select
        ActiveSheet.Paste
    End With

    Whiteboard.Close
    WordDoc.Close
    Word.Quit

End Sub

Answer 1

根据 cmets，我已修改代码以删除使用 .Select、.Activate 等类型语句

Sub TorCopy()

    ' Set variables
    Dim Word As New Word.Application
    Dim WordDoc As New Word.Document
    Dim i As Integer
    Dim j As Integer
    Dim r As Word.range
    Dim Doc_Path As String
    Dim TOR_Tracker As Excel.Workbook
    Dim TOR_Tracker_Path As String
    Dim Whiteboard_Path As String
    Dim Whiteboard As Excel.Workbook
    Dim whiteSheet as Worksheet
    Dim torSheet as Worksheet
    Dim n As Integer

    ' Set File Path that contains TOR
    ' Open File
    Doc_Path = "C:\Word_File.doc"
    Set WordDoc = Word.Documents.Open(Doc_Path)

    TOR_Tracker_Path = "C:\Tracker_Spreadsheet.xlsm"
    Set TOR_Tracker = Workbooks.Open(TOR_Tracker_Path)
    Set torSheet = TOR_Tracker.Worksheets("Sheet1")

    Whiteboard_Path = "C:\Excel_Spreadsheet_Acting_As_A_Whiteboard.xlsm"
    Set Whiteboard = Workbooks.Open(Whiteboard_Path)
    Set whiteSheet = Whiteboard.Worksheets("Sheet1")

    ' Create a range to search
    Set r = WordDoc.Content

    j = 1

    ' Find TOR numbers and copy them to whiteboard spreadsheet
    With r
        .Find.ClearFormatting
        With .Find
            .Text = "TP[0-9]{4}"
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = True
        End With
        Do While .Find.Execute = True
            .Copy
            whiteSheet.Cells(j, 1).PasteSpecial
            j = j + 1
        Loop
    End With

    ' Filter out duplicate TOR numbers
    n = whiteSheet.Cells(whiteSheet.Rows.Count, "A").End(xlUp).Row
    whiteSheet.range("A1:A" & n).RemoveDuplicates Columns:=1, Header:=xlNo
    n = whiteSheet.Cells(whiteSheet.Rows.Count, "A").End(xlUp).Row ' re-getting the last row now duplicates are removed

    lastRowTor = torSheet.Cells(torSheet.Rows.Count, "A").End(xlUp).Row

    torSheet.Range("A" & lastRowTor & ":A" & (lastRowTor + n)-1).Value = whiteSheet.Range("A1:A" & n).Value ' sets values in Tor from White without Select, Copy or Paste

    Whiteboard.Close
    WordDoc.Close
    Word.Quit

End Sub