XL 2016 MACRO LENTE

ImNotJésus

XLDnaute Nouveau
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
 

Wayki

XLDnaute Impliqué
Bonjour,
Pour peu que vous soyez dans un environnement onedrive ça va être très long oui.
Voyez ceci pour alléger votre code, vous pouvez enlever les select etc
Un_Objet_Excel_Quelconque.Select
Selection.Une_Methode_Quelconque
par
Un_Objet_Excel_Quelconque.Une_Methode_Quelconque
A +
 

Discussions similaires