Ошибка 1004 Вставить Метод класса рабочего листа не выполнен, прерывистый

Question

Целью этого кода является поиск и копирование номера из документа Word в таблицу Excel. Это происходит не всегда, но я получаю ошибку 1004 время от времени, когда я запускаю этот скрипт. Отладчик выделяет первый оператор «ActiveSheet.Paste», который находится под «Do While Loop» как проблема с кодом. Я не вижу никаких конфликтов с какой-либо другой частью скрипта. Кто-нибудь заметил что-нибудь неправильное?

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

Согласно комментариям, я изменил код, чтобы удалить использование .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