Optimisation de mon code (Traitement de 1 minute environ)
Bonjour à tous,
Je me suis lancé dans l'écriture d'un code qui fonctionne actuellement mais qui met un peu plus d'une minute à s'éxécuter !
Il s'agit d'analyser les données extraites d'une base de données (avec un mise en forme dégueulasse), et de la classer par catégorie.
Pour rentrer dans le vif du sujet,
J'ai différentes feuilles sur lesquelles il faut faire la même action. Je dois chercher dans la colonne A dans valeurs puis les comparer avec les valeurs de la colonne A d'une autre feuille.
Pour essayer d'être clair, je cherche un code famille dans une colonne, que je compare avec la liste totale des codes familles et dès que je trouve, je viens copier le total à coté du nom de la famille globale (j'espère que vous êtes bien réveillé).
J'ai rajouté une petite action de supprimer les lignes qui contiennent (en blanco) dans les cellules de la colonne A.
Mon souci :
J'ai 6 feuilles donc comme un débutant qui se respecte, j'ai dupliqué mon code 6 fois en l'adaptant. Pour l'instant pour chaque feuille, je ne sélectionne qu'une partie de la liste de code famille globale (à voir si on peut tout scanner).
Donc c'est pas super optimisé
Et puis, mon temps de traitement et de 1 minute ... parce que je compare parfois 35.000 lignes d'une feuille avec 50 lignes d'une autre alors forcément ca prend du temps
Dans le code ci-dessous, j'explique en commentaire ce que j'ai voulu faire.
Sub Bouton1_Cliquer()
Dim CAT_INTERV As Variant, CAT_GLOBAL As Variant
Dim NB_INTERV As Variant, NB_INTERV_GLOBAL As Variant
Dim i As Integer, j As Integer
Application.ScreenUpdating = False
'***************************
' Feuille F_A
'***************************
'___ Suppression des lignes dont la cellule de la colonne A contient (en blanco)
'Va chercher toutes les lignes non vide de la colonne A de la feuille F_A
jLR = Worksheets("F_A").Range("A" & Rows.Count).End(xlUp).Row
Sheets("F_A").Select
'Permet de scanner toute la plage de la cellule A2 à la dernière non vide la colonne A
For o = 2 To jLR
If Cells(o, "A").Value Like "*(en blanco)*" Then
'On supprime la ligne qui contient (en blanco)
Sheets("F_A").Cells(o, "A").Delete shift:=xlUp
End If
Next o
'___ Fin de la suppression pour la feuille F_A
For i = 2 To Worksheets("F_A").Range("A" & Rows.Count).End(xlUp).Row
'On compare les valeurs de la colonne A de la feuille F_A avec les valeurs de la feuille FAMILY DETAILS
'Quand on trouve la même, on copie la valeur de la ligne à la colonne B (pour le cas F_A) ou C (pour les autres)
For j = 4 To 21
CAT_INTERV = Worksheets("F_A").Cells(i, "A")
CAT_GLOBAL = Worksheets("FAMILY DETAILS").Cells(j, "A")
If CAT_INTERV = CAT_GLOBAL Then
With Sheets("F_A")
.Cells(i, "B").Copy _
Sheets("FAMILY DETAILS").Cells(j, "C")
End With
GoTo suite
Else
End If
Next j
suite:
Next i
'***************************
' Feuille F_E
'***************************
'Va chercher toutes les lignes non vide de la colonne A de la feuille F_A
kLR = Worksheets("F_E").Range("A" & Rows.Count).End(xlUp).Row
Sheets("F_E").Select
For o = 2 To kLR
If Cells(o, "A").Value Like "*(en blanco)*" Then
Sheets("F_E").Cells(o, "A").Delete shift:=xlUp
End If
Next o
For i = 2 To Worksheets("F_E").Range("A" & Rows.Count).End(xlUp).Row
For j = 70 To 123
CAT_INTERV = Worksheets("F_E").Cells(i, "A")
CAT_GLOBAL = Worksheets("FAMILY DETAILS").Cells(j, "A")
If CAT_INTERV = CAT_GLOBAL Then
With Sheets("F_E")
.Cells(i, "C").Copy _
Sheets("FAMILY DETAILS").Cells(j, "C")
End With
GoTo suite2
Else
End If
Next j
suite2:
Next i
'***************************
' Feuille F_F
'***************************
'Va chercher toutes les lignes non vide de la colonne A de la feuille F_A
lLR = Worksheets("F_F").Range("A" & Rows.Count).End(xlUp).Row
Sheets("F_F").Select
For o = 2 To lLR
If Cells(o, "A").Value Like "*(en blanco)*" Then
Sheets("F_F").Cells(o, "A").Delete shift:=xlUp
End If
Next o
For i = 2 To Worksheets("F_F").Range("A" & Rows.Count).End(xlUp).Row
For j = 124 To 168
CAT_INTERV = Worksheets("F_F").Cells(i, "A")
CAT_GLOBAL = Worksheets("FAMILY DETAILS").Cells(j, "A")
If CAT_INTERV = CAT_GLOBAL Then
With Sheets("F_F")
.Cells(i, "C").Copy _
Sheets("FAMILY DETAILS").Cells(j, "C")
End With
GoTo suite3
Else
End If
Next j
suite3:
Next i
'***************************
' Feuille F_H
'***************************
mLR = Worksheets("F_H").Range("A" & Rows.Count).End(xlUp).Row
Sheets("F_H").Select
For o = 2 To mLR
If Cells(o, "A").Value Like "*(en blanco)*" Then
Sheets("F_H").Cells(o, "A").Delete shift:=xlUp
End If
Next o
For i = 2 To Worksheets("F_H").Range("A" & Rows.Count).End(xlUp).Row
For j = 169 To 198
CAT_INTERV = Worksheets("F_H").Cells(i, "A")
CAT_GLOBAL = Worksheets("FAMILY DETAILS").Cells(j, "A")
If CAT_INTERV = CAT_GLOBAL Then
With Sheets("F_H")
.Cells(i, "C").Copy _
Sheets("FAMILY DETAILS").Cells(j, "C")
End With
GoTo suite4
Else
End If
Next j
suite4:
Next i
'***************************
' Feuille F_R
'***************************
nLR = Worksheets("F_R").Range("A" & Rows.Count).End(xlUp).Row
Sheets("F_R").Select
For o = 2 To nLR
If Cells(o, "A").Value Like "*(en blanco)*" Then
Sheets("F_R").Cells(o, "A").Delete shift:=xlUp
End If
Next o
For i = 2 To Worksheets("F_R").Range("A" & Rows.Count).End(xlUp).Row
For j = 199 To 213
CAT_INTERV = Worksheets("F_R").Cells(i, "A")
CAT_GLOBAL = Worksheets("FAMILY DETAILS").Cells(j, "A")
If CAT_INTERV = CAT_GLOBAL Then
With Sheets("F_R")
.Cells(i, "C").Copy _
Sheets("FAMILY DETAILS").Cells(j, "C")
End With
GoTo suite5
Else
End If
Next j
suite5:
Next i
'***************************
' Feuille F_V
'***************************
oLR = Worksheets("F_V").Range("A" & Rows.Count).End(xlUp).Row
Sheets("F_V").Select
For o = 2 To oLR
If Cells(o, "A").Value Like "*(en blanco)*" Then
Sheets("F_V").Cells(o, "A").Delete shift:=xlUp
End If
Next o
For i = 2 To Worksheets("F_V").Range("A" & Rows.Count).End(xlUp).Row
For j = 214 To 251
CAT_INTERV = Worksheets("F_V").Cells(i, "A")
CAT_GLOBAL = Worksheets("FAMILY DETAILS").Cells(j, "A")
If CAT_INTERV = CAT_GLOBAL Then
With Sheets("F_V")
.Cells(i, "C").Copy _
Sheets("FAMILY DETAILS").Cells(j, "C")
End With
GoTo suite6
Else
End If
Next j
suite6:
Next i
Sheets("FAMILY DETAILS").Cells(2, "A").Select
Application.ScreenUpdating = True
End SubJ'ai mis la version light en PJ car je suis limité à 300k
En espérant qu'un généreux développeur anonyme et dévoué puisse me venir en aide !
Merci d'avance,
Floo73
Bonjour Floo, bonjour le forum,
Je te propose le code ci-dessous (non testé) :
Sub Bouton1_Cliquer()
Dim OS As Variant 'déclare la variable OS (OngletS)
Dim F As Worksheet 'déclare la variable F (Onglet FAMILY DETAILS)
Dim I As Byte 'déclare la variable I (Incrément)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim JD As Integer 'déclare la variable JD(J Début)
Dim JF As Integer 'déclare la variable JD(J Fin)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim PL As Range 'déclare la variable PL (PLage)
Dim LI As Integer 'déclare la variable LI (LIgne)
Dim TCF As Variant 'déclare la variable TCF (Tableau de Cellules onglet F)
Dim J As Byte 'déclare la variable J (incrément)
Dim CAT_INTERV As Variant, CAT_GLOBAL As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'calcul manuel des formules
OS = Array("F_A", "F_E", "F_F", "F_H", "F_R", "F_V") 'définit les onglets OS
Set F = Sheets("FAMILY DETAILS") 'définit l'onglet F
For I = LBound(OS, 1) To UBound(OS, 1) 'boucle 1 : sur tous les onglets OS
Set O = Sheets(OS(I)) 'définit l'onglet O
Select Case O.Name 'agit en fonction du nom de l'onglet O
Case "F_A"
JD = 4: JF = 21 'définit les variables JD et JF
Case "F_E"
JD = 70: JF = 123 'définit les variables JD et JF
Case "F_F"
JD = 124: JF = 168 'définit les variables JD et JF
Case "F_H"
JD = 169: JF = 198 'définit les variables JD et JF
Case "F_R"
JD = 199: JF = 213 'définit les variables JD et JF
Case "F_V"
JD = 214: JF = 251 'définit les variables JD et JF
End Select 'fin de l'action en fonction du nom de l'onglet
TC = O.Range("A2").CurrentRegion 'définit le tableau de cellules TC
Set PL = O.Range("A1") 'initialise la palge PL
For LI = 2 To UBound(TC, 1) 'boucle 2 : sur toutes les lignes LI du tableau de cellules TC
If TC(LI, 1) Like "*(en blanco)*" Then
Set PL = IIf(PL.Address = "$A$1", O.Cells(LI, 1), Application.Union(PL, O.Cells(LI, 1))) 'redéfinit la plage PL
End If
Next LI 'prochaine ligne de la boucle 2
If PL.Address <> "$A$1" Then PL.Delete shift:=xlUp 'efface la plage PL
TC = O.Range("A2").CurrentRegion 'redéfinit le tableau de cellules TC
TCF = F.Range("A2").CurrentRegion 'définit le tableau de cellules TCF (à adapter)
For LI = 2 To UBound(TC, 1)
For J = JD To JF
CAT_INTERV = TC(LI, 1) 'définit la variable CAT_INTERV
CAT_GLOBAL = TCF(J, 1) 'définit la variable CAT_GLOBAL
If CAT_INTERV = CAT_GLOBAL Then 'condition : si les deux variables sont égales
O.Cells(LI, 2).Copy F.Cells(J, 3) 'copie la cellule ligne LI colonne 2 de l'onglet O dans la cellule ligne J colonne 3 de l'onglet F
Exit For 'sort de la boucle 4
End If 'fin de la condition
Next J 'prochaine valeur de la boucle 4
Next LI 'prochaine ligne de la boucle 3
Next I 'prochain onglet de la boucle 1
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic 'calcul automatique des formules
End SubMerci ThauThème pour ta réponse !
J'essaye de capter, je teste et je te fais un retour !
En tout cas ... j'espère t'arriver à la cheville un jour
A plus tard,
Et merciiii !
Bonjour Floo, bonjour le forum,
Attention j'ai édité et modifié deux fois le code après avoir découvert que tu avais mis un fichier en pièce jointe.
Refait un copier/coller du code du premier post mis à jour...
Bonjour Floo, bonjour le forum,
Maintenant que j'ai le fichier sous les yeux, je ne comprends ce que tu veux faire avec la boucle qui Delete Shilf:= xlUp les cellules vides en colonne A. Il me semble que ça devrait effacer non pas la cellule mais la ligne ! Me trompe-je ?...
Merciii !
Oui je veux effectivement effacer la ligne pour allèger le nombre de données sur chaque feuille.
Les lignes qui contiennent (en blanco) sont des espèces de sous-totaux qui ne font pas avancer le schmilblik !
J'ai essayé ton code et ca marche du tonnerre ! J'ai adapté quelques trucs de mise en forme des données initiales :
- Dans la feuille F_A les colonnes B et C étaient inversées
- Dans la feuille FAMILY DETAILS j'ai fais un tri dans l'ordre alphabétique, sinon les plages de comparaison que l'on sélectionne ne correspondent plus aux codes des différentes feuilles
En tout cas merci beaucoup, je ne connaissais pas encore les "tableaux" mais c'est un outil visiblement très puissant quand on compare des plages de données !
Une dernière fois merci ? Ouiii !! --> MERCIIII !
Bonne journée à toi,
Cdlt,
Floo