title: Worksheet.Paste running extremely slowly
body: <p>My code below uses the country name in the file name to identify that country's row in the Countries sheet and then copy offset values.</p>
  <p>It uses Worksheet.Paste, but runs extremely slowly and breaks after five or six files (out of 50+ files), so I would be grateful for tips on tuning this.</p>
  <p>The same code using Range.Copy and Destination runs fine, but Destination cannot be used to paste links.</p>
  <pre><code>Sub Header_Paste_Link()
  
  Dim Path As String, Filename As String, Country As String, _
  Name As String, Leftname As String
  Dim wb As Workbook
  Dim i As Integer
  Dim rng As Range
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  
  Path = &quot;C:\Users\xyz\Documents\xyz\xyz\&quot;
  Filename = Dir(Path &amp; &quot;*.xlsx&quot;)
  
  On Error GoTo PasteFail
  
  Do While Len(Filename) &gt; 0
  
      Set wb = Workbooks.Open(Path &amp; Filename)
      
  CopyX:
  
      Name = wb.Name
      Leftname = Left(Name, InStr(Name, &quot;_&quot;) - 1)
      With wb.Sheets(&quot;Countries&quot;).Range(&quot;A:A&quot;)
          Set rng = .Find(What:=Leftname, _
                              After:=.Cells(1), _
                              LookIn:=xlValues, _
                              LookAt:=xlWhole, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False)
              If Not rng Is Nothing Then
              
              rng.Offset(, 2).Copy _
              Worksheets(&quot;Header&quot;).Range(&quot;B1&quot;).Activate
              ActiveSheet.Paste Link:=True
              Worksheets(&quot;Header&quot;).Range(&quot;G1&quot;).Activate
              ActiveSheet.Paste Link:=True
              
              rng.Offset(, 3).Copy
              Worksheets(&quot;Header&quot;).Range(&quot;D1&quot;).Select
              ActiveSheet.Paste Link:=True
  
              rng.Offset(, 5).Copy
              Worksheets(&quot;Header&quot;).Range(&quot;I1&quot;).Select
              ActiveSheet.Paste Link:=True        
  
              End If
      End With
  
      i = i + 1
      ActiveWorkbook.Close savechanges:=True
      Filename = Dir
  Loop
  
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  
  PasteFail:
      If Err.Number = 4605 Then
          DoEvents
          Resume CopyX
      ElseIf Err.Number = 1004 Then
          Resume CopyX
      Else
          GoTo ErrMsg
      End If
  
  ErrMsg:
      MsgBox Err.Number &amp; vbCr &amp; Err.Description
      
  End Sub
  </code></pre>