XL 2016 MACRO LENTE

Bonjours,

J'ai créé une macro pour splitter une base de donnée en plusieurs fichiers.

Mais j'ai 150 fichiers à créer et pour en faire seulement 6 je mets 3 min.

Voici ma macro

Merci d'avance.


Sub Fichier()
Dim chemin As Variant
Dim fichier_Test As Variant
Dim agence As Variant
Dim Nomfi As Variant
Dim NomfiB As Variant
Dim Fichier As Variant
Dim Zone As Variant

classeur = ThisWorkbook.FullName
chemin = ThisWorkbook.Path
NomfiB = ThisWorkbook.Sheets("Liste").Range("R4")
'Masque
Fichier = ThisWorkbook.Sheets("Liste").Range("I1")
Nomfi = ThisWorkbook.Sheets("Liste").Range("G1")
Application.Calculation = xlManual
Application.ScreenUpdating = False

'Initialisez la boucle
I = O
ThisWorkbook.Sheets("Liste").Select
agence = Range("A1").Offset(I, 0).Value
Do Until agence = ""

Application.Workbooks.Open classeur
Sheets("Liste").Select
agence = Range("A1").Offset(I, 0).Value
NomEDR = Range("D1").Offset(I, 0).Value
NomTCD = Range("E1").Offset(I, 0).Value
Zone = Range("F1").Offset(I, 0).Value
If agence = "" Then
GoTo 1
End If

chemin = ThisWorkbook.Path


'suppréssion de la base puis Copier coller des données
Sheets("EDR - Cumul").Select
Sheets("EDR - Cumul").Range("$A$4", Selection.End(xlDown)).AutoFilter Field:=4, Criteria1:= _
agence
Range("$A$4:$CA$4").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Workbooks.Open Filename:= _
chemin & "\" & Fichier & ".xlsx"
ActiveWorkbook.AutoSaveOn = False
Sheets("EDR - Hierarchie").Select

Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("EDR - Hierarchie").Select
Sheets("EDR - Hierarchie").Name = NomEDR

Sheets("Tcd++Hierarachie").Select
Sheets("Tcd++Hierarachie").Name = NomTCD
Range("A1").Select
ActiveWorkbook.RefreshAll


'Sauvegarde du fichier
ActiveWorkbook.SaveAs Filename:=chemin & "/" & Zone & " " & agence & " " & Nomfi & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close


I = I + 1
Loop
1
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Sheets("EDR - Cumul").Select
Sheets("EDR - Cumul").Range("$A$4", Selection.End(xlDown)).AutoFilter Field:=4

MsgBox "fini"

End Sub