エラー1004ワークシートクラスの貼り付け方法が失敗した、断続的

Question

このコードの目的は、ワードドキュメントからExcelスプレッドシートに数値を検索してコピーすることです。すべての時間に起こるわけではありませんが、このスクリプトを実行すると時々1004エラーが発生します。デバッガは、の最初の "ActiveSheet.Paste"ステートメントを強調表示します。ステートメントは、コードの問題として "Do While Loop"の下にあります。私はスクリプトの他の部分との競合を見ていません。誰でも間違った点を見つけますか？ TOR_Tracker.Worksheetsは（「シート1」）doesnのインスタンスは、これまで

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

コメントを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