XL 2019 Macro qui ralenti mon classeur après exécution

Option Explicit
Public Const ParamSendUsing As String = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Public Const ParamServeur As String = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
Public Const ParamPort As String = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Public Const ParamIdentificateur As String = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Public Const ParamIdentifiant As String = "http://schemas.microsoft.com/cdo/configuration/sendusername"
Public Const ParamMotDePasse As String = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
Public Const ParamSsl As String = "http://schemas.microsoft.com/cdo/configuration/smtpusessl"

Sub EnvoiMailCDO()
Dim CdoMessage, CdoConfig, CdoParam
Dim Var1 As String                                             ' nom
Dim Chemin As String                                     'chemin du fichier
Dim NFichier As String                                      'Nom du fichier
Dim titre As String
Dim strbody As String
Var1 = [D6].Value              
If Var1 = Empty Then
MsgBox "Veuillez préciser le nom et le prénom !", vbYes, "PL"
Exit Sub
End If
Application.ScreenUpdating = False
Dim Sh1 As Worksheet
Set Sh1 = Feuil5 'A adapter si besoin en fonction du codename de la feuille 1
With Sh1.PageSetup
.PrintArea = "A1:N115" 'Zone d'impression à adapter de la feuille 1
.Zoom = False
.FitToPagesWide = 3
.FitToPagesTall = 3
'Réglage des marges
.LeftMargin = Application.InchesToPoints(1.2) 'Marge gauche
.RightMargin = Application.InchesToPoints(0.1) 'Marge droite
.TopMargin = Application.InchesToPoints(0.5) 'Marge haut de page
.BottomMargin = Application.InchesToPoints(0.1) 'Marge bas de page
.Orientation = xlLandscape 'Paysage     ' .Orientation = xlPortrait 'Portrait
End With
Sheets(Array(Sh1.name)).Select

Chemin = Application.ActiveWorkbook.Path   ' 'direction du fichier pdf
'If Dir(Chemin, vbDirectory) = "" Then MkDir Chemin

NFichier = ThisWorkbook.Path & "\" & "PROSPECT" & "-" & Sh1.Range("G3") & "-" & Format(Date, "dd-mm-yyyy") & ".pdf" 'Création du fichier pdf
'Création du fichier PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=NFichier, Quality _
        :=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Set CdoConfig = CreateObject("CDO.Configuration")
    CdoConfig.Load -1
    Set CdoParam = CdoConfig.Fields

    With CdoParam
    .Item(ParamSendUsing) = 2
    .Item(ParamServeur) = [T9].Value
    .Item(ParamPort) = [T10].Value
    .Item(ParamIdentificateur) = "1"
    .Item(ParamIdentifiant) = [T12].Value    'Votre Identifiant
    .Item(ParamMotDePasse) = [T13].Value  'Votre mot de passe
    .Item(ParamSsl) = "true"
    .Update
    End With

    Set CdoMessage = CreateObject("CDO.Message")
    With CdoMessage
        Set .Configuration = CdoConfig
        .From = [T4].Value
        .To = [T5].Value
        .CC = [T6].Value 'destinataires en copie (CC)
        .BCC = [T7].Value 'destinataires en copie cachée (CCI)
        .Subject = "Relevé d'informations" & " " & "de" & " " & [D5] & " " & [G3] & "," & " dossier: " & [T16]
        .TextBody = "Bonjour," & vbNewLine & vbNewLine & "veuillez trouver ci-joint les informations de" & " " & [D5] & " " & [G3] & "," & " dossier: " & [T16] & vbNewLine & vbNewLine & "Cordialement" & vbNewLine & vbNewLine & "PL" & " : " & [T3]

    .Fields("urn:schemas:mailheader:disposition-notification-to") = [T4].Value
    .Fields("urn:schemas:mailheader:return-receipt-to") = [T4].Value
    .Fields.Update
        .AddAttachment NFichier
        .Send
    End With
    MsgBox "Le relevé a bien été envoyé !"
    Kill NFichier
    Set CdoMessage = Nothing
    Set CdoConfig = Nothing
    Set CdoParam = Nothing
    Set Sh1 = Nothing 'Decharge la feuille 1
    Application.ScreenUpdating = True
End Sub