XL 2016 Problème temps d'execution code

[Hogwarts]

Bonjour,

J'ai crée un début de macro dont l'objectif est d'aller récupérer des valeurs dans une colonne 'D' présent dans un onglet "TEST" et ceux dans plusieurs fichiers présents dans un dossier "mon_dossier".
L'idée est que ma macro se trouve dans un dossier parent de "mon_dossier" ou se trouve mes fichiers sur lequel je lance ma macro.

Mon problème dans ma macro, est pour aller récupérer cette colonne D. Le seul moyen que j'ai trouvé pour y arriver est via une boucle for qui s'ajoute à une première. Et ces deux boucle FOR, me donne une durée d'exécution de la macro vraiment très long.

Pensez vous que je peux passer outre cette seconde boucle For ?

Merci d'avance.

Sub test()
Application.ScreenUpdating = False

Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean

BoEcran = Application.ScreenUpdating
BoBarre = Application.DisplayStatusBar
iCalcul = Application.EnableEvents
BoEvent = Application.EnableEvents
BoSaut = ActiveSheet.DisplayPageBreaks

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

Dim ws As Worksheet
Dim monFichier As String
Dim wb As Workbook
Dim chemin As String
Dim i As Integer
Dim nom As String
Dim FichierMain As String

Set wb = Workbooks(ThisWorkbook.Name)
Dim sh As Worksheet
chemin = ThisWorkbook.Path & "\mon_dossier\"

monFichier = Dir(chemin & "*.xlsx", vbNormal)

Do While monFichier <> ""
    Debug.Print monFichier
        onglet = Split(monFichier, "_")(4)
        
        wb.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = onglet
       For Each sh In ActiveWorkbook.Worksheets
            For i = 8 To 150
            'J'aimerais pouvoir parcourir toutes les lignes de la colonne j=4 donc D mais cette boucle est vraiment trop longue
                'TEST
                j = 4
                Cells(i - 4, j - 2).Formula = "='" & ThisWorkbook.Path & "\[" & monFichier & "]TEST'!R" & i & "C" & j:
            Next
        Next sh
    monFichier = Dir
Loop

Application.ScreenUpdating = True 'Facultatif
BoEcran = Application.ScreenUpdating = BoEcran
BoBarre = Application.DisplayStatusBar = BoBarre
iCalcul = Application.EnableEvents = iCalcul
BoEvent = Application.EnableEvents = BoEvent
BoSaut = ActiveSheet.DisplayPageBreaks = BoSaut

End Sub

Merci d'avance.

 

[sylvanu]

Bonsoir Hogwarts,
Dommage que vous n'ayez pas fourni les fichiers adéquat.
Avec ce que j'ai compris, le dossier en PJ avec :

Sub test()

Dim ws As Worksheet
Dim monFichier As String
Dim wb As Workbook
Dim chemin As String
Dim i%, nom$, Nb%, T0

T0 = Timer          ' Pour meure temps d'execution
Fige                ' Fige événements
Supprime            ' Supprime toute feuille pour test répétitif

Set wb = Workbooks(ThisWorkbook.Name)
Dim sh As Worksheet
chemin = ThisWorkbook.Path & "\mon_dossier\"

monFichier = Dir(chemin & "*.xlsx", vbNormal)

Do While monFichier <> ""
    Nb = Nb + 1
        onglet = Split(monFichier, "_")(4)
        wb.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = onglet
            nom = ThisWorkbook.Path & "\mon_dossier\" & monFichier
            Workbooks.Open (nom)                                            ' ouvre fichier
            tablo = Sheets("TEST").Range("D8:D150")                         ' copie données dans array
            Workbooks(monFichier).Close False                               ' ferme fichier
            Range("$D$1").Resize(UBound(tablo)) = tablo                     ' range données dans feuille
        monFichier = Dir
Loop

Sheets("Header").Select
[C3] = Nb: [C5] = Round(1000 * (Timer - T0), 0)
Libere
End Sub

Pour aller vite il faut éviter de lire et écrire des cellules, c'est plus rapide en passant par des arrays.
N'ayant pas votre temps d'exécution, je ne peux que vous inviter à tester cette PJ pour voir si c'est plus rapide, et surtout voir si ça fait ce que vous voulez.
Lancer le fichier Hogwarts/Hogwarts.xlsm

 

[Hogwarts]

Bonsoir,

Un immense merci !!
Je n'avais pas du tout pensé au fonction Open et Close, merci infiniment c'est parfait !

Très bonne soirée à vous.