Macro mets 30 min à tourner
Bonjour
J'ai une macro qui consiste à créer 75 fichiers en automatique à partir d'un fichier source qui fait des recherches. Le problème est qu'elle met 35 min à tourner ! alors que je l'ai testé pour un autre fichier (création de 65 fichiers) et ça net mets que 2min..
Y a t il une solution svp ?
Merci d'avance.
Cdt,
Hajar
Bonjour,
Déjà, nous montrer le code !
Bonjour
Ci-dessous la macro
Option Explicit
Sub Archiver()
Dim wk1 As Workbook, CC As Workbook
Dim wk2 As String, chemin As String, extension As String, Pays As String
Dim i As Integer, n As Integer
Dim lks As Variant
Application.DisplayAlerts = False
chemin = ThisWorkbook.Path & "\"
Set wk1 = ThisWorkbook
wk2 = "Pays test macro.xlsx"
extension = ".xlsx"
Application.ScreenUpdating = False
For n = 4 To 77 'adapter à la plage de cellules Nom de pays
Pays = wk1.Sheets("Feuil1").Range("A" & n) 'adapter à la plage de cellules Nom de pays
If Pays <> "" Then
Workbooks(wk2).Sheets("E2258_1").Range("A6") = Pays
Workbooks(wk2).SaveAs Filename:=chemin & "Test_" & Pays & extension, FileFormat:=51
Set CC = Workbooks("Test_" & Pays & extension)
On Error Resume Next
CC.ActiveSheet.DrawingObjects(1).Delete
On Error GoTo 0
lks = CC.LinkSources(1)
If Not IsEmpty(lks) Then
For i = 1 To UBound(lks)
CC.BreakLink Name:=lks(i), Type:=xlExcelLinks
Next i
End If
CC.Close SaveChanges:=True
Workbooks.Open chemin & wk2
End If
Next n
Application.ScreenUpdating = True
Application.DisplayAlerts = False
End Sub
Salut,
Juste pour savoir dans ton fichier source (pour en faire 75) ,tu as des différences avec celui qui en fait 65?
Par exemple il y a des liens entre classeur ? des formules ? c'est un fichier partagé ?
Si c'est la même macro qui tourne sur le même pc, je ne pense pas que le code en lui même soit en cause du coup
ECG
Bonsoir,
Pour gagner du temps, ne serait il pas plus rapide de supprimer les liens sur le fichier source et de les rétablir à la fin et de même pour l'objet ? Ceci éviterai les 70 instructions dans la boucle. Une piste pour mémoriser les liaisons et les rétablir ensuite. La fonction qui retourne un tableau :
Function MemoFormules(Fe As Worksheet) As Variant()
Dim Tbl()
Dim Cel As Range
Dim Chemin As String
Dim I As Integer
For Each Cel In Fe.Cells.SpecialCells(xlCellTypeFormulas)
Chemin = Replace(Cel.Formula, "='", "")
Chemin = Replace(Chemin, "[", "")
On Error Resume Next
Chemin = Left(Chemin, InStr(Chemin, "]") - 1)
On Error GoTo 0
If Dir(Chemin) <> "" Then
I = I + 1
ReDim Preserve Tbl(1 To 2, 1 To I)
Tbl(1, I) = Cel.Address
Tbl(2, I) = Cel.Formula
End If
Next Cel
MemoFormules = Tbl()
End Functionappelée de la façon suivante :
Dim Tbl()
Tbl = MemoFormules(wk1.Sheets("Feuil1"))et à la fin du code, remise en place des formules dans le fichier source :
For I = 1 To UBound(Tbl, 2): Range(Tbl(1, I)).Formula = Tbl(2, I): Next IEnfin, c'est une piste !
Bonjour,
Une piste à étudier, à comprendre et adapter. A savoir que quand on copie une ou plusieurs feuilles d'un classeur sans en préciser la destination, un nouveau classeur est créé avec la ou les feuilles copiées. Ceci évite après l'enregistrement sous... de devois à nouveau ouvrir le classeur original donc, probablement un gain de temps. N'ayant pas testé, je ne peux pas savoir le temps d'exécution de la proc. Dans mon code, l'objet (wk1.ActiveSheet.DrawingObjects(1).Delete) est détruit avant la boucle, il suffit de le re-créer en fin de code mais ne sachant pas de quel objet il s'agit, je n'est pas mis le code de création :
Sub Archiver()
Dim wk1 As Workbook
Dim wk2 As Workbook
Dim Chemin As String, extension As String, Pays As String
Dim I As Integer, n As Integer
Dim lks As Variant
Dim Tbl()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wk1 = ThisWorkbook
Set wk2 = Workbooks("Pays test macro.xlsx") '<--- il doit être ouvert !
Chemin = ThisWorkbook.Path & "\"
extension = ".xlsx"
'adapter le nom de la feuille, créer autant de tableaux que de feuilles
'et appeler plusieurs fois la fonction si nécessaire
Tbl = MemoFormules(wk1.Worksheets("Feuil1"))
'si liaisons...
If Tbl(1, 1) <> "Aucune valeur" Then
lks = wk1.LinkSources(1)
If Not IsEmpty(lks) Then
For I = 1 To UBound(lks): wk1.BreakLink lks(I), 1: Next I
End If
End If
'suppression de l'objet qui sera à re-créé
'peut être en mémoriser le type afin de le re-créé plus facilement, à voir...
On Error Resume Next
wk1.ActiveSheet.DrawingObjects(1).Delete
On Error GoTo 0
For n = 4 To 77 'adapter à la plage de cellules Nom de pays
Pays = wk1.Sheets("Feuil1").Range("A" & n) 'adapter à la plage de cellules Nom de pays
If Pays <> "" Then
wk2.Sheets("E2258_1").Range("A6") = Pays
'si la destination de la copie n'est pas précisée, un classeur est créé avec la ou les feuilles copiées
'adapter le nom de la ou des feuilles copiées dans le nouveau classeur
wk1.Worksheets(Array("Feuil1", "Feuil3")).Copy '<--- si une seule feuille, supprimer l'Array()
'le classeur nouvellement créé devient le classeur actif
ActiveWorkbook.SaveAs Chemin & "Test_" & Pays & extension, 51
ActiveWorkbook.Close True
'le classeur n'étant pas fermé lors de l'enregistrment sous... plus la peine de l'ouvrir à nouveau donc, gain de temps
'''Workbooks.Open chemin & wk2
End If
Next n
'remise en place des liaisons, adapter le nom de la feuille
For I = 1 To UBound(Tbl, 2): wk1.Worksheets("Feuil1").Range(Tbl(1, I)).Formula = Tbl(2, I): Next I
'ici, création de l'objet supprimé plus haut...
Application.ScreenUpdating = True
Application.DisplayAlerts = False
End Sub
Function MemoFormules(Fe As Worksheet) As Variant()
Dim Tbl()
Dim Cel As Range
Dim Chemin As String
Dim I As Integer
On Error GoTo Fin
For Each Cel In Fe.Cells.SpecialCells(xlCellTypeFormulas)
Chemin = Replace(Cel.Formula, "='", "")
Chemin = Replace(Chemin, "[", "")
On Error Resume Next
Chemin = Left(Chemin, InStr(Chemin, "]") - 1)
On Error GoTo 0
If Dir(Chemin) <> "" Then
I = I + 1
ReDim Preserve Tbl(1 To 2, 1 To I)
Tbl(1, I) = Cel.Address
Tbl(2, I) = Cel.Formula
End If
Next Cel
MemoFormules = Tbl()
Exit Function
Fin:
ReDim Tbl(1 To 1, 1 To 1)
Tbl(1, 1) = "Aucune valeur"
MemoFormules = Tbl()
End FunctionBonjour
Merci pour votre retour. les liens sont indispensables car chaque variable entrée, les liens doivent se réactualiser pour afficher les bonnes valeurs donc je ne peux pas les supprimer en premier
Merci
Hajar
bonjour,
j'ai essayé la macro mais en fait elle ne fait que reproduire le fichier source en plusieurs fichiers, ce qui n'est pas le but de ma macro initiale..
effectivement dans ce cas elle met moins de temps à tourner !
Bonjour,
...chaque variable entrée...
Le nom du pays je suppose ?
Bonjour
Oui tout à fait
Re,
Il faudrait poster les deux classeurs liés afin de voir les formules et, selon le cas, voir si il est possible de réduire le temps d'exécution de la macro ?
Il faudrait poster les classeurs sans données confidentielles !
Bonjour
Ci-joint la macro sur laquelle j'ai pu économiser 30 min de tournage (elle passe de 40 min à 10 min mnt), le fichier principal qui sert à alimenter les fichiers, et le fichier modèle de création des sous fichiers;
Idéalement je voudrais que la macro me supprime les colonnes A et B quand elle finit de créer chaque fichier car ce sont des colonnes qui me servent uniquement de recherchev mais ça je n'ai pas encore trouvé..
merci d'avance pour votre aide précieuse !
cdt
Hajar
Bonjour,
Désolé du retard !
Avec le code ci-dessous, et par rapport aux classeurs postés, il mets chez moi 28 secondes à créer tous les classeurs (74 par rapport aux classeurs postés). Il faut savoir que les formules sont supprimées donc les liaisons et seules les valeurs correspondantes sont récupérées par l'intermédiaire de la fonction Find(). Voir commentaires dans le code :
Sub Archiver()
Dim wk1 As Workbook
Dim wk2 As Workbook
Dim CC As Workbook
Dim Plage As Range
Dim PlgVal As Range
Dim Cel As Range
Dim Chemin As String, extension As String, Pays As String
Dim n As Integer
Dim Debut As Date
Debut = Time 'pour la mesure du temps d'exécution
Application.ScreenUpdating = False
Set wk1 = ThisWorkbook
Set wk2 = Workbooks("Pays test macro.xlsx") '<--- il doit être ouvert !
Chemin = ThisWorkbook.Path & "\"
extension = ".xlsx"
With Workbooks("Final.xlsx").Worksheets("Feuille 1"): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
'supprime les valeurs et formules de la ligne 6 du classeur "Pays test macro.xlsx"
wk2.Worksheets("Feuille 1").Rows(6).ClearContents
For n = 4 To 77
Pays = wk1.Sheets("Feuil1").Range("A" & n)
If Pays <> "" Then
'la recherche est effectuée sur la colonne A où se trouvent les pays...
Set Cel = Plage.Find(Pays, , xlValues, xlWhole)
'si trouvé...
If Not Cel Is Nothing Then
'copie la feuille dans un nouveau classeur pour avoir la mise en forme et les valeurs non supprimées
wk2.Worksheets("Feuille 1").Copy
Set CC = ActiveWorkbook
'défini la plage sur la ligne de la valeur cherchée...
With Workbooks("Final.xlsx").Worksheets("Feuille 1"): Set PlgVal = .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, .Columns.Count).End(xlToLeft)): End With
'et colle ces valeurs en ligne 6
With CC.Worksheets("Feuille 1"): .Range(.Cells(6, 1), .Cells(6, PlgVal.Columns.Count)).Value = PlgVal.Value: End With
'enregistre et ferme
CC.SaveAs Chemin & "Test_" & Pays & extension, 51
ActiveWorkbook.Close True
End If
End If
Next n
Application.ScreenUpdating = True
'affiche le temps d'exécution
MsgBox Format(Time - Debut, "hh:mm:ss")
End SubBonjour
Merci pour la macro ça marche impec ùais ça ne me copie que le premier onglet..j'ai besoin qu'elle fasse la copie sur les trois onglets où j'ai des formules de recherche..sinon rapidité top !
merci d'avance
Cdt
Hajar
Bonjour,
Ok, je regarde ça quand j'ai un peu de temps et te re poste un code !
Bonjour,
Voici le nouveau code à tester :
Sub Archiver()
Dim wk1 As Workbook
Dim wk2 As Workbook
Dim CC As Workbook
Dim Plage As Range
Dim PlgVal As Range
Dim Cel As Range
Dim Chemin As String, extension As String, Pays As String
Dim n As Integer
Dim Debut As Date
Dim Adr As String
Dim Lgn As Long
Dim I As Integer
Debut = Time 'pour la mesure du temps d'exécution
Application.ScreenUpdating = False
Set wk1 = ThisWorkbook
Set wk2 = Workbooks("Pays test macro.xlsx") '<--- il doit être ouvert !
Chemin = ThisWorkbook.Path & "\"
extension = ".xlsx"
For n = 4 To 77
Pays = wk1.Sheets("Feuil1").Range("A" & n)
'supprime les valeurs et formules de la ligne 6 du classeur "Pays test macro.xlsx"
wk2.Worksheets("Feuille 1").Rows(6).ClearContents
wk2.Worksheets("Feuille 2").Rows("6:25").ClearContents
wk2.Worksheets("Feuille 3").Rows("6:25").ClearContents
If Pays <> "" Then
'----feuille "Feuille 1"-----
With Workbooks("Final.xlsx").Worksheets("Feuille 1"): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
'la recherche exacte sur la colonne A
Set Cel = Plage.Find(Pays, , xlValues, xlWhole)
'si trouvé...
If Not Cel Is Nothing Then
With Workbooks("Final.xlsx").Worksheets("Feuille 1"): Set PlgVal = .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, .Columns.Count).End(xlToLeft)): End With
With wk2.Worksheets("Feuille 1"): .Range(.Cells(6, 1), .Cells(6, PlgVal.Columns.Count)).Value = PlgVal.Value: End With
End If
For I = 2 To 3
'----feuilles "Feuille 2" et "Feuille 3"-----
With Workbooks("Final.xlsx").Worksheets("Feuille " & I): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
'recherche partielle sur la colonne A
Set Cel = Plage.Find(Pays, , xlValues, xlPart)
'si trouvé...
If Not Cel Is Nothing Then
Adr = Cel.Address
Do
With Workbooks("Final.xlsx").Worksheets("Feuille " & I): Set PlgVal = .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, .Columns.Count).End(xlToLeft)): End With
With wk2.Worksheets("Feuille " & I)
Lgn = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If Lgn < 6 Then Lgn = 6
.Range(.Cells(Lgn, 1), .Cells(Lgn, PlgVal.Columns.Count)).Value = PlgVal.Value
End With
Set Cel = Plage.FindNext(Cel)
Loop While Cel.Address <> Adr
End If
Next I
'copie la feuille dans un nouveau classeur pour avoir la mise en forme et les valeurs non supprimées
wk2.Worksheets(Array("Feuille 1", "Feuille 2", "Feuille 3")).Copy
ActiveWorkbook.SaveAs Chemin & "Test_" & Pays & extension, 51
ActiveWorkbook.Close True
End If
Next n
Application.ScreenUpdating = True
'affiche le temps d'exécution
MsgBox Format(Time - Debut, "hh:mm:ss")
End SubBonjour
Merci pour la macro
je n'ai pas pu la tester car au niveau du code suivant je ne peux pas laisser Feuille vu qu'en fait mes onglets sont renommés différemment. Que proposez vous comme solution svp ?
'----feuilles "Feuille 2" et "Feuille 3"-----
With Workbooks("Final.xlsx").Worksheets("Feuille " & I): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
Cdt
Hajar
Re,
En utilisant un tableau (Array) où seront indiqués en début de code les noms des feuilles :
Sub Archiver()
Dim wk1 As Workbook
Dim wk2 As Workbook
Dim CC As Workbook
Dim Plage As Range
Dim PlgVal As Range
Dim Cel As Range
Dim TblFe
Dim Chemin As String, extension As String, Pays As String
Dim n As Integer
Dim Debut As Date
Dim Adr As String
Dim Lgn As Long
Dim I As Integer
Debut = Time 'pour la mesure du temps d'exécution
Application.ScreenUpdating = False
Set wk1 = ThisWorkbook
Set wk2 = Workbooks("Pays test macro.xlsx") '<--- il doit être ouvert !
Chemin = ThisWorkbook.Path & "\"
extension = ".xlsx"
'ici, adapter les noms des feuilles !
TblFe = Array("Feuille 2", "Feuille 3") '<------ !!!
For n = 4 To 77
Pays = wk1.Sheets("Feuil1").Range("A" & n)
'supprime les valeurs et formules des feuilles du classeur "Pays test macro.xlsx"
wk2.Worksheets("Feuille 1").Rows(6).ClearContents
wk2.Worksheets("Feuille 2").Rows("6:25").ClearContents
wk2.Worksheets("Feuille 3").Rows("6:25").ClearContents
If Pays <> "" Then
'----feuille "Feuille 1"-----
With Workbooks("Final.xlsx").Worksheets("Feuille 1"): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
'recherche exacte sur la colonne A
Set Cel = Plage.Find(Pays, , xlValues, xlWhole)
'si trouvé...
If Not Cel Is Nothing Then
With Workbooks("Final.xlsx").Worksheets("Feuille 1"): Set PlgVal = .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, .Columns.Count).End(xlToLeft)): End With
With wk2.Worksheets("Feuille 1"): .Range(.Cells(6, 1), .Cells(6, PlgVal.Columns.Count)).Value = PlgVal.Value: End With
End If
For I = 0 To UBound(TblFe)
'----autres feuilles dont les noms sont dans le tableau "TblFe"-----
With Workbooks("Final.xlsx").Worksheets(TblFe(I)): Set Plage = .Range(.Cells(6, 1), .Cells(.Rows.Count, 1).End(xlUp)): End With
'recherche partielle sur la colonne A
Set Cel = Plage.Find(Pays, , xlValues, xlPart)
'si trouvé...
If Not Cel Is Nothing Then
Adr = Cel.Address
Do
With Workbooks("Final.xlsx").Worksheets(TblFe(I)): Set PlgVal = .Range(.Cells(Cel.Row, 1), .Cells(Cel.Row, .Columns.Count).End(xlToLeft)): End With
With wk2.Worksheets(TblFe(I))
Lgn = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If Lgn < 6 Then Lgn = 6
.Range(.Cells(Lgn, 1), .Cells(Lgn, PlgVal.Columns.Count)).Value = PlgVal.Value
End With
Set Cel = Plage.FindNext(Cel)
Loop While Cel.Address <> Adr
End If
Next I
'adapter les noms des feuilles ici aussi !!!
wk2.Worksheets(Array("Feuille 1", "Feuille 2", "Feuille 3")).Copy
ActiveWorkbook.SaveAs Chemin & "Test_" & Pays & extension, 51
ActiveWorkbook.Close True
End If
Next n
Application.ScreenUpdating = True
'affiche le temps d'exécution
MsgBox Format(Time - Debut, "hh:mm:ss")
End SubBonjour
Merci pour la maco impec niveau rapidité
par contre les deux derniers onglets ne contiennent plus de valeurs alors que dans le fichier source ils sont censés chercher des valeurs dans le premier onglet selon le pays..
merci pour votre aide
Cdt
Hajar
Attention, le code que je t'ai donné a été fait en fonction des classeurs postés ! Tu as dû remarquer que la feuille "Feuille 2" du classeur "Final.xlsx" ne contient pas de valeur de la ligne 6 à 24 ? Par contre, par exemple, le classeur Test_CL.xlsx contient en feuille "Feuille 1" des valeurs en ligne 6 de A à R, en feuille "Feuille 2" des valeurs de A6 à U10 concernant CL1 à CL6 et en feuille "Feuille 3" des valeurs de A6 à AA10 concernant CL1 à CL6 où en AA10 il y a un X.
Je te poste ce classeur afin que tu vois les résultats car pour moi, ça marche à priori très bien, mais par rapport aux classeurs que tu as posté. Si les classeurs réels sont différents, forcément les résultats le seront aussi !
PS : Sur mon petit PC portable, les classeurs sont créés en 29 secondes, sur mon PC de bureau ils sont créés en 14 secondes !