VBA - Macro lente, s'arrête et repars

Bonjour à tous !

Je possède une macro qui réalise exactement ce que je souhaite (elle ouvre différents fichiers excel et vient copier les valeurs de certaines cellules identifiées pour les coller dans un un fichier excel global d'où part la macro, dans un tableau). Jusqu'ici tout va bien.

Le souci est que cette macro pendant son fonctionnement, a tendance à faire des "pauses" de presque 40 secondes sur chacun des fichiers qu'elle parcourt. Ce qui fait que son execution est longue, d'autant que je ne peux pas utiliser excel pendant ces pauses. Au final, ma macro met presque 15 min pour compléter sa tâche. Ces pauses interviennent sur des cases différentes à chaque fois.

Peut-être que je n'ai pas optimisé mon code au mieux ?

Mon code est le suivant:

Dim k As Long

Sub Consolider_SharePoint_Alpha3()
    Dim S_Commande
    Dim Chemin As String
    Dim Extension As String

    Set S_Commande = ThisWorkbook.Sheets("Commande")
    Chemin = S_Commande.Cells(3, 3).Value
    Extension = S_Commande.Cells(5, 2).Value
    k = 2

    Nb = BoucleFichiers(Chemin, Extension)
    MsgBox (Nb & " groupements de données importés")

End Sub

Function BoucleFichiers(Chemin As String, Extension As String) As Integer
    Dim Fso As Object
    Dim Dossier As Object
    Dim Fichier As Object
    Dim WB_TargetFichier As Workbook
    Dim TargetSheet As Worksheet
    Dim MainSheet As Worksheet
    Dim AL1 As Object
    Dim ch As String
    Dim d0 As String
    Dim d1 As String
    Dim V As Range
    Dim W As Range
    Dim X As Range
    Dim COL As Byte
    Dim i As Long
    Dim CEL As Range
    Dim PL As Range

    Set AL1 = CreateObject("System.Collections.ArrayList")
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set MainSheet = ThisWorkbook.Sheets("Synthèse")
    BoucleFichiers = 0

    For Each Dossier In Fso.GetFolder(Chemin).SubFolders
     d0 = Left(Dossier, 3)
     d1 = Right(Dossier, Len(Dossier) - 3)
       AL1.Add d1
    Next Dossier

    AL1.Sort  'tri par ordre alpha
   R = AL1.Toarray()

    For j = LBound(R) To UBound(R)
         ch = d0 & R(j)

            For Each Fichier In Fso.GetFolder(ch).Files
              fich = ch & Fichier
              Debug.Print ch

                If Left(Fichier.Name, 17) = "PLAN_RENTABILITE_" Then

                    Set WB_TargetFichier = Workbooks.Open(ch & "\" & Fichier.Name)
                    Set TargetSheet = WB_TargetFichier.Sheets("PARP")
                    Set PL = Application.Union(TargetSheet.Range("E4"), TargetSheet.Range("C9"), TargetSheet.Range("H6:H7"), TargetSheet.Range("H9:H16"), TargetSheet.Range("H18:H19"), TargetSheet.Range("M9"), TargetSheet.Range("M11"), TargetSheet.Range("Q9"), TargetSheet.Range("Q11"), TargetSheet.Range("P15"), TargetSheet.Range("L15"), TargetSheet.Range("P19"), TargetSheet.Range("L19"), TargetSheet.Range("AC4:AC25"))
                    i = 1

                            For Each CEL In PL

                                CEL.Copy
                                MainSheet.Cells(k, i).PasteSpecial Paste:=xlPasteValues
                                i = i + 1

                            Next CEL
                    k = k + 1
                    Application.CutCopyMode = False
                    BoucleFichiers = BoucleFichiers + 1
                    WB_TargetFichier.Close savechanges:=False

                End If

            Next Fichier

    Next j
Set AL1 = Nothing
End Function

Je vous joins mon fichier excel aussi mais je ne peux pas vous transmettre le Sharepoint et les fichiers cibles

Merci à vous,

SkillzZ