Worksheet.Paste running extremely slowly

Question

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.

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.

The same code using Range.Copy and Destination runs fine, but Destination cannot be used to paste links.

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 = "C:\Users\xyz\Documents\xyz\xyz\"
Filename = Dir(Path & "*.xlsx")

On Error GoTo PasteFail

Do While Len(Filename) > 0

    Set wb = Workbooks.Open(Path & Filename)
    
CopyX:

    Name = wb.Name
    Leftname = Left(Name, InStr(Name, "_") - 1)
    With wb.Sheets("Countries").Range("A:A")
        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("Header").Range("B1").Activate
            ActiveSheet.Paste Link:=True
            Worksheets("Header").Range("G1").Activate
            ActiveSheet.Paste Link:=True
            
            rng.Offset(, 3).Copy
            Worksheets("Header").Range("D1").Select
            ActiveSheet.Paste Link:=True

            rng.Offset(, 5).Copy
            Worksheets("Header").Range("I1").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 & vbCr & Err.Description
    
End Sub

Answer 1

Using Activate and Select causes a slowdown. You can replace Copy and .Paste Link:=True by setting .Formula (without formatting; if relevant). Also the Application.Match is faster then .Find. Try this fragment of code (partially tested):

With wb.Sheets("Countries")
    m = Application.Match(Leftname, .Range("A:A"), 0)
    If IsNumeric(m) Then
        Set Rng = .Cells(m, "A")
        With Worksheets("Header")
            .Range("B1").Formula = "=" & Rng.Offset(, 2).Address(External:=True)
            .Range("G1").Formula = "=" & Rng.Offset(, 2).Address(External:=True)
            .Range("D1").Formula = "=" & Rng.Offset(, 3).Address(External:=True)
            .Range("I1").Formula = "=" & Rng.Offset(, 5).Address(External:=True)
        End With
    End If
End With