Error 1004 Paste Method of Worksheet Class Failed, Intermittent

Question

The purpose of this code is to search for and copy a number from a word document to an excel spreadsheet. It doesn't happen all of the time, but I am getting the 1004 error from time to time when I run this script. The debugger highlights the first "ActiveSheet.Paste" statement, which is under the "Do While Loop" as the problem with the code. I am not seeing any conflicts with any other part of the script. Anyone spot anything incorrect?

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

As per the comments, I've modified the code to remove the use of .Select, .Activate etc type statements

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