Optimisation Code suite grosse lenteur d'exécution
Bonjour;
@patrick T C'est parfaitement ça. Merci à toi
Bonjour patrick T,
Merci à toi pour ton retour,
Il y a un truc qui va pas
Exemple dans la PJ que je te joint (j'ai allégé le fichier pour faire un test simplifié) j'ai un total de 1998 lignes:
==> Dans la Feuille13 il y a 998 lignes
==> Dans la Feuille14 il y a 1000 lignes
alors que lorsque j'exécute la macro il trouve 1478 lignes :
==> Dans la Feuille13 il trouve 739 lignes
==> Dans la Feuille14 il trouve 741 lignes
Je cherche mais j'arrive pas à trouver l'erreur (j'étudie encore ton code pour apprendre)
J'expose de nouveau le besoin je me suis peut-être mal exprimé
1. A partir de la 12 -ème feuille si colonne A contient le chiffre "0" alors copier toute la ligne
2. Coller les lignes dans la feuille All_Name
3. Supprimer toutes les colonnes sauf
C ==> Classe
F ==> 1C
G ==> 2C
I ==> 4C
J ==> 5C
4. Si colonne A contient doublon alors supprimer la ligne en doublon
5. Ajouter 2 colonnes et nommer
Entity
Product Line
6. Agencer/Renommer les colonnes
Colonne A ==> ID
Colonne B ==> Nom
Colonne C ==> Prenom
Colonne D ==> Entity
Colonne E ==> Contract
Colonne F ==> Product Line
Colonne G ==> Manager
re
j'ai tres bien compris le truc
chez moi c'est 100% ok avec le fichier donné en exemple au depart
si il y a des erreurs sporadiques c'est que tu nous a pas tout dit sur tes feuilles originales
et pour info par ce avec toi il faut quand même avoir un décodeur
c'est pas
C ==> Classe
F ==> 1C
G ==> 2C
I ==> 4C
J ==> 5C
mais
C ==> Classe
F ==> 1C
G ==> 2C
j==> 4C
i ==> 5C
qui se transforme en
ID ==> anciennement Classe donc C
Nom ==> anciennement 1C donc F
prenom ==> anciennement 2C donc G
entity==> nouvelle insérée
contract ==> anciennement 4C donc J
productline == nouvelle insérée
managerI ==> anciennement 5C donc i
apres si des données en colonne A sont mal interprétées c'est qu'il y a un probleme de format
si 0 et pas vide c'est 0 c'est simple comme bonjour il n'y a pas d'ambiguité
donc conclusion soit tu le fait tout seul et tu vérifie ligne par ligne sur chaque fichier si il n'y a pas quelques lignes qui serait pas en format text
ou je ne sais quoi mais mon alogo est sans appel si c'est 0 et non vide on garde
voila voila sans fichier avec des données vraissemblable je ne peux tester
moi j'ai fait avec les exemples que tu a donné
Re patrick T
Oui dsl le fichier d'origine est trop complexe (je suis pas l'auteur de ce fichier) j'ai essayer de le simplifier au mieux (je peux m'en mêler les pinceaux)
il y avait effectivement du texte et des colonnes A vide que j'ai supprimé mais je viens de refaire le test et j'ai toujours pas les mêmes données
==> Sur le code j'ai 2950 lignes à valeurs uniques (sur 5913 lignes contenant le chiffre "0" dans la colonne A)
==> Puis j'ai repris manuellement toutes les lignes contenant le chiffre "0" puis supprimer les doublons et j' ai 3992 valeurs uniques (sur 7725 lignes contenant le chiffre "0" dans la colonne A)
Il y ' a une différence de 1812 lignes contenant le chiffre "0" soit 442 lignes à valeurs uniques.
Je comprend pas où est mon erreur pourtant j'utilise bien ton dernier fichier
Bonjour patrick T,
Je me trompe peut-être mais j'ai refait différents tests avec des 0 partout et des 0 mis aléatoirement.
En mettent des 0 partout il copie bien toutes les lignes par contre en supprimant les doublons j'ai une différence de 4 entre la suppression avec macro et suppression manuelle (en rouge sur l'image ci-dessous)
J'ai refait un test avec des 0 mis aléatoirement et là je m'aperçois qu'il ne copie pas que les lignes contenant des 0
Exemple : il copie aarón avec accent alors que c'est en chiffre 1 mais pas aaron sans accent qui lui contient 0
re
a ben oui si il y a des refs c'esdt sur
donc le test sera if cells(i,"A").text="0" comme ca c'est explicit
je revois ça je reviens tout à l'heure
re
bon ben c'est vrai il copie des "1" aussi
la par contrre je comprends pas j'ai essayé en textuel explicite et c'est pareil
For LiG = 1 To SH.Cells(Rows.Count, 2).End(xlUp).Row 'boucle de la ligne 1 à la dernière
If Trim(SH.Cells(LiG, "A").Text) = "0" Then 'si la condition est remplie
A = A + 1: ReDim Preserve arrligne(1 To A): arrligne(A) = LiG 'on incrémente la matrice de ligne et on y intègre l'index de ligne "lig"
End If
Nextet le résultat j'ai bien des "1" dans les copies
comme la condition est textuelle et explicite
If Trim(SH.Cells(LiG, "A").Text) = "0" Then j'en conclu que c'est tes feuilles qui sont pourries
d'ailleurs il me semble te l'avoir deja dit
si une condition comme celle là laisse passer des "1" ou autres alors je ne peux rien faire
je perdrais mon temps a essayé de corriger la macro puis qu'il n'y a pas d'erreur , j'ai testé avec des feuilles a moi
et j'ai 100% de zero
ma conclusion c'est qu'avant de vouloir faire une macro pour faire ce genre de travail il faudrait vérifier si les données sont conformes
Mille Merci patrick T je vais pas t'embêter plus longtemps je vais repartir sur ton code essayer de trouver d'où vient l'erreur chez moi
J'ai bien checker le fichier il n'est pas pollué je vois pas où sont les truc "pourri" tout me semble normale
En tout cas merci beaucoup !!!!!!!!!!! c'est un excellent code très riche pour apprendre et en terme d'exécution il est très rapide faut juste que je trouve l'erreur chez moi je vais me renseigner droite à gauche pour voir.
Excellente fin de journée à toi et encore merci
re
j'ai fini par trouvé l'erreur sur XLD je t'ai répondu
voila tu n'aura plus les "1"
Option Explicit
Sub testX()
Dim colonne, SH, A&, MsG$, LiG&, RnG, TotaL&, TabLresulT, I&
colonne = Array(2, 3, 6, 7, 1, 10, 1, 9) 'matrice de colonne
Sheets("All_Name").Cells.Clear ' vide la feuille All_Name
DoEvents
Application.ScreenUpdating = False
For I = 13 To Sheets.Count 'boucle de 13 à sheets.count
ReDim arrligne(1 To 1) 'on redim la matrice de ligne a chaque feuille
Set SH = Sheets(I)
A = 0
For LiG = 1 To SH.Cells(Rows.Count, 2).End(xlUp).Row 'boucle de la ligne 1 à la dernière
If Val(SH.Cells(LiG, "A")) = 0 And SH.Cells(LiG, "A") <> "" Then 'si la condition est remplie
A = A + 1: ReDim Preserve arrligne(1 To A): arrligne(A) = LiG 'on incrémente la matrice de ligne et on y intègre l'index de ligne "lig"
If LiG < 20 Then Debug.Print "ligne " & LiG & " " & SH.Cells(LiG, 1) & "---" & SH.Cells(LiG, 2)
End If
Next
MsG = MsG & SH.Name & " copie= " & A & " ligne(s)" & vbLf 'on ajoute au texte du message
TotaL = TotaL + A 'on calcule le total de lignes
Set RnG = SH.Range("A1:AA" & SH.Cells(Rows.Count, 2).End(xlUp).Row - 1) 'on prend toute la plage
TabLresulT = Application.Index(RnG.Value, Application.Transpose(arrligne), colonne) 'récupération du tableau selon la matrice de ligne et colonne
With Sheets("All_Name").Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Resize(UBound(arrligne), UBound(colonne) + 1) = TabLresulT 'injection du tableau dans la ligne dispo a partir d'en bas
End With
Next
With Sheets("All_Name")
'suppression des doublons
.Range("$A$1:$AA$" & .Cells(Rows.Count, "a").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo 'suppression des doublons
TotaL = .Cells(Rows.Count, "B").End(xlUp).Row 'total des ligne récupérées
.Columns(1).Delete
'Suppression des colonnes non utilisées
.Range("d:d,f:f").Clear 'vidage des colonne que l'on a récupéré et qui sont les colonnes ajoutées
'Nommer les Entêtes
.Range("A1").Resize(, 7) = Array("ID", "Nom", "Prenom", "Entity", "contract", "Product line", "manager") 'Entêtes de colonne
'design du tableau
'***********************************************************
'soit en range
' With .Range("A1:H" & .Cells(Rows.Count, 1).End(xlUp).Row)
' With .Rows(1)
' .Interior.Color = RGB(0, 0, 255) ' Bleu
' .Font.Color = RGB(255, 255, 255) ' Blanc
' .Font.Bold = True
' End With
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlCenter
'.Borders(xlEdgeLeft).LineStyle = xlContinuous
' .Borders(xlEdgeTop).LineStyle = xlContinuous
'.Borders(xlEdgeRight).LineStyle = xlContinuous
' .Borders(xlEdgeBottom).LineStyle = xlContinuous
'.Borders(xlInsideVertical).LineStyle = xlContinuous
'.Borders(xlInsideHorizontal).LineStyle = xlContinuous
' End With
'*********************************************************
'ou tout simplement en listobject(tableau structuré)
.ListObjects.Add(xlSrcRange, .Range("A1:G" & .Cells(Rows.Count, 1).End(xlUp).Row), , xlYes).Name = "Tableau1"
'*************************************************
[A1].Select
.Shapes("bouton").Left = 550
End With
MsgBox MsG & vbCrLf & "Pour un total de " & TotaL & " lignes" & vbCrLf & " en ayant supprimé les doublons "
Application.ScreenUpdating = True
End SubBonjour patrickT,
ça fonctionne nickel merci beaucoup !!!!!!!!!!!!!!!!!!!!!!!! Je vais pouvoir dormir ce soir et désolé encore pour ce temps perdu
Bonne soirée à toi !!!!!!!!!
re
bonsoir tonton95
allors rapide ou pas rapide chez toi?
Bonjour patrickT,
Je fait encore des tests mais je peux te dire que ton code n'est pas rapide, il est hyper rapide même pas 1 minute d'exécution sur le fichier originale VS + de 15 minutes avec mon code y a pas photo. C'est au delà de mes attentes merci infiniment.
j'essaie encore de comprendre qu'es qui fait que ton code est aussi performant. je vais l'étudier pour bien comprendre (et ne pas galérer pour la maintenance aussi
J'ai fait des tests pour l'ajout de colonne que j'ai réussi à faire par contre j'ai rajouter 2 lignes avant l'entête (pour une évolution futur) c'est dans quelle ligne de code pour lui dire de commencer à partir de la 4eme lignes ?
J'ai fait le test sur mon fichier mais il prend la 1ère ligne
Merci encore un bijou ton code
bonjour
KADO
regarde tout en bas du code
Option Explicit
Sub testX()
Dim colonne, SH, A&, MsG$, LiG&, RnG, TotaL&, TabLresulT, I&, plus
colonne = Array(2, 3, 6, 7, 1, 10, 1, 9) 'matrice de colonne
With Sheets("All_Name"): .Range("A5:AA" & .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row).Clear: End With ' vide la feuille All_Name
DoEvents
Application.ScreenUpdating = False
For I = 13 To Sheets.Count 'boucle de 13 à sheets.count
ReDim arrligne(1 To 1) 'on redim la matrice de ligne a chaque feuille
Set SH = Sheets(I)
A = 0
For LiG = 2 To SH.Cells(Rows.Count, 2).End(xlUp).Row 'boucle de la ligne 1 à la dernière
If Val(SH.Cells(LiG, "A")) = 0 And SH.Cells(LiG, "A") <> "" Then 'si la condition est remplie
A = A + 1: ReDim Preserve arrligne(1 To A): arrligne(A) = LiG 'on incrémente la matrice de ligne et on y intègre l'index de ligne "lig"
If LiG < 20 Then Debug.Print "ligne " & LiG & " " & SH.Cells(LiG, 1) & "---" & SH.Cells(LiG, 2)
End If
Next
MsG = MsG & SH.Name & " copie= " & A & " ligne(s)" & vbLf 'on ajoute au texte du message
TotaL = TotaL + A 'on calcule le total de lignes
Set RnG = SH.Range("A1:AA" & SH.Cells(Rows.Count, 2).End(xlUp).Row - 1) 'on prend toute la plage
TabLresulT = Application.Index(RnG.Value, Application.Transpose(arrligne), colonne) 'récupération du tableau selon la matrice de ligne et colonne
If I = 13 Then plus = 4 Else plus = 0
With Sheets("All_Name").Cells(Rows.Count, 1).End(xlUp).Offset(1 + plus)
.Resize(UBound(arrligne), UBound(colonne) + 1) = TabLresulT 'injection du tableau dans la ligne dispo a partir d'en bas
End With
Next
With Sheets("All_Name")
'suppression des doublons
.Range("$A$5:$AA$" & .Cells(Rows.Count, "a").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo 'suppression des doublons
TotaL = .Cells(Rows.Count, "B").End(xlUp).Row 'total des ligne récupérées
.Columns(1).Delete
'Suppression des colonnes non utilisées
.Range("d:d,f:f").Clear 'vidage des colonne que l'on a récupéré et qui sont les colonnes ajoutées
'Nommer les Entêtes
.Range("A5").Resize(, 7) = Array("ID", "Nom", "Prenom", "Entity", "contract", "Product line", "manager") 'Entêtes de colonne
'design du tableau
'***********************************************************
'soit en range
' With .Range("A1:H" & .Cells(Rows.Count, 1).End(xlUp).Row)
' With .Rows(1)
' .Interior.Color = RGB(0, 0, 255) ' Bleu
' .Font.Color = RGB(255, 255, 255) ' Blanc
' .Font.Bold = True
' End With
' .HorizontalAlignment = xlCenter
' .VerticalAlignment = xlCenter
'.Borders(xlEdgeLeft).LineStyle = xlContinuous
' .Borders(xlEdgeTop).LineStyle = xlContinuous
'.Borders(xlEdgeRight).LineStyle = xlContinuous
' .Borders(xlEdgeBottom).LineStyle = xlContinuous
'.Borders(xlInsideVertical).LineStyle = xlContinuous
'.Borders(xlInsideHorizontal).LineStyle = xlContinuous
' End With
'*********************************************************
'ou tout simplement en listobject(tableau structuré)
.ListObjects.Add(xlSrcRange, .Range("A5:G" & .Cells(Rows.Count, 1).End(xlUp).Row), , xlYes).Name = "Tableau1"
'*************************************************
' .Rows("1:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
With ActiveWindow: .SplitColumn = 0: .SplitRow = 5: .FreezePanes = True: End With
[A1].Select
With .Shapes("bouton"): .Left = 550: .Top = 20: End With
'*********************************************************************************
'TU PEUX CODER CE QUE TU VEUX FAIRE OU METTRE DANS LAPLAGE [A1:AA4] ICI
'**********************************************************************************
End With
MsgBox MsG & vbCrLf & "Pour un total de " & TotaL & " lignes" & vbCrLf & " en ayant supprimé les doublons "
Application.ScreenUpdating = True
End Subje t'ai même mis un freezepane pour que tu puisque scroller les données sans perdre l'entête et ce que tu veux mettre au dessus
ca c'est du sur messure
re
maintenant j'explique pourquoi il est plus rapide
avant tu bouclais ligne par ligne et tu copiais a chaque tour la ligne si les conditions etaient bonnes
ca avait pour effet de declencher tout les event de la feuille All_Name bien sur et je parle surtout du calculate
moi je fait autrement
je boucle sur tout les ligne
je stock l'index de ligne dans une variable tableau arrligne (2 dim x ligne et 1 colonne)
ensuite je récupère tout les lignes dans une variable tableau TabLresulT avec application index(toute la feuille , arrligne , colone)
pour aide à la compréhension
'****************************************************************
application index(toute la feuille , arrligne , colonne)
=
application.index(plage de cellule , variable tableau 2 dim(xligne,1 colonne) , array 1 dim pour les colonnes)
'****************************************************************
et j'envois TabLresulT dans la feuille All_Name
autrement dit avant tu copiais autant de fois que de ligne 0 trouvées
moi je copie juste autant de fois que de feuille a partir de la 13eme feuille
toute les lignes de chaque feuille en une seule fois a chaque feuille
voila
d'autre part j'evite tout les select et activate et autre cochonnerie du genre
ce qui fait que la macro peut être executé a partir de n'inporte quelle feuille
sauf pour le freezpane que je viens de t'ajouter pour l'ergonomie (pour que tu puisse scroller la feuille sans perdre l'entête et ce que tu veux mettre dans la partie jaune
voila voila
Re,
Un grand grand merci pour ces explication ça devient un peu plus claire je vais encore me pencher dessus faire des milliers de tests en modifiant le code ligne par ligne pour bien comprendre leur rôle
==> tu peux m'expliquer cette ligne là stp surtout le < 20
If LiG < 20 Then Debug.Print "ligne " & LiG & " " & SH.Cells(LiG, 1) & "---" & SH.Cells(LiG, 2)Concernant le dernier fichier en pj avec l'ajout de ligne dans la feuille All_Name je le garde pour un autre besoin qui reprend cette modification (magnifique merci beaucoup!!!!!)
Pour le moment ,c'est l'inverse dans la feuille All_Name je ne vais pas rajouter de ligne
Feuille All_Name
c'est sur les autres feuille (à partir de de 13eme que je vais rajouter 2 lignes) comme ci-dessous.
Avec le code corrigé de Mardi à 19:29 quand j'exécute le code sur le fichier d'origine sans le rajout de ligne ça marche nikel mais quand je rajoute 2 lignes sur les feuilles (à partir de la 13ème il me récupère et colle aussi la 1ere ligne dans la feuille All_Name
C'est cette 1ere ligne que je veux qu'il ignore il doit pas la prendre en compte
Merci d'avance!!!!!!!!
Bonjour tonton95
cette ligne peut être supprimée
maintenant si tes lignes commencent en ligne 3 donc +1 pour l'entête dans tes 13 à X
le code on le modifie légèrement
Option Explicit
Sub testX()
Dim colonne, SH, A&, MsG$, LiG&, RnG, TotaL&, TabLresulT, I&, plus
colonne = Array(2, 3, 6, 7, 1, 10, 1, 9) 'matrice de colonne
With Sheets("All_Name"): .Range("A5:AA" & .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row).Clear: End With ' vide la feuille All_Name
DoEvents
Application.ScreenUpdating = False
For I = 13 To Sheets.Count 'boucle de 13 à sheets.count
ReDim arrligne(1 To 1) 'on redim la matrice de ligne a chaque feuille
Set SH = Sheets(I)
A = 0
For LiG = 4 To SH.Cells(Rows.Count, 2).End(xlUp).Row 'boucle de la ligne 1 à la dernière
If Val(SH.Cells(LiG, "A")) = 0 And SH.Cells(LiG, "A") <> "" Then 'si la condition est remplie
A = A + 1: ReDim Preserve arrligne(1 To A): arrligne(A) = LiG 'on incrémente la matrice de ligne et on y intègre l'index de ligne "lig"
End If
Next
MsG = MsG & SH.Name & " copie= " & A & " ligne(s)" & vbLf 'on ajoute au texte du message
TotaL = TotaL + A 'on calcule le total de lignes
Set RnG = SH.Range("A1:AA" & SH.Cells(Rows.Count, 2).End(xlUp).Row - 1) 'on prend toute la plage
TabLresulT = Application.Index(RnG.Value, Application.Transpose(arrligne), colonne) 'récupération du tableau selon la matrice de ligne et colonne
If I = 13 Then plus = 0 Else plus = 1
With Sheets("All_Name").Cells(Rows.Count, 1).End(xlUp).Offset(1 + plus)
.Resize(UBound(arrligne), UBound(colonne) + 1) = TabLresulT 'injection du tableau dans la ligne dispo a partir d'en bas
End With
Next
With Sheets("All_Name")
'suppression des doublons
.Range("A:AA").RemoveDuplicates Columns:=1, Header:=xlYes 'suppression des doublons
TotaL = .Cells(Rows.Count, "B").End(xlUp).Row 'total des ligne récupérées
.Columns(1).Delete
'Suppression des colonnes non utilisées
.Range("d:d,f:f").Clear 'vidage des colonne que l'on a récupéré et qui sont les colonnes ajoutées
'Nommer les Entêtes
.Range("A1").Resize(, 7) = Array("ID", "Nom", "Prenom", "Entity", "contract", "Product line", "manager") 'Entêtes de colonne
.ListObjects.Add(xlSrcRange, .Range("A1:G" & .Cells(Rows.Count, 1).End(xlUp).Row), , xlYes).Name = "Tableau1"
'*************************************************
' .Rows("1:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
With ActiveWindow: .SplitColumn = 0: .SplitRow = 1: .FreezePanes = True: End With
[A1].Select
With .Shapes("bouton"): .Left = 550: .Top = 100: End With
'*********************************************************************************
End With
MsgBox MsG & vbCrLf & "Pour un total de " & TotaL & " lignes" & vbCrLf & " en ayant supprimé les doublons "
Application.ScreenUpdating = True
End SubBonjour patrickT,
Merci pour ton retour. J'ai fini mes tests voici le résultat
Mon code :
Ton code Code :
Clairement y ' a pas photo ton code est une aussi rapide que l'éclaire
Désolé encore pour XLD j'ai vue ta petite note
mais je trouvais pas l'erreur chez moi alors que chez toi ça fonctionné il me fallait un œil nouveau pour m'éclairer
Tout ça à cause d'un 2 à la place du 1 je suis pas près de l'oublier
En tous cas merci merci infiniment de ton aide et ton expertise !!!!!!!!!!
Bonne journée à tous !!!!!!!!!!!!!!!
hah!!.... à la bonne heure
et encore je trouve que 48 secondes c'est long
tu dois avoir beaucoup plus que 1000 lignes par feuille ou beaucoup plus de feuille
chez moi avec ton exemple donc 7 feuilles de 1000 lignes 00:00:00 , 125
125 Nano secondes en fait soit même pas le quart d'une seconde
Oui oui patrickT le fichier d'origine contient beaucoup beaucoup de lignes plus de 15 000 c'est pour ça