Récupérer plusieurs items associées à un objet
Bonsoir,
voici, j'ai optimisé le code, et mis un message de progression 3 phases 1, 2A, 2B, et 3
Sub check()
'
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsc = Worksheets("Checks")
' i numéro de feuille
i = 0
' wsci numéro de dernière ligne dans checks
wsci = 2
' on boucle sur les feuilles dans l'ordre
For Each wsname In Array("Ref2", "Ref1", "perimetre")
i = i + 1
Set ws = Worksheets(wsname)
dls = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If i = 1 Then 'Ref2
Application.StatusBar = "phase 1 0%"
' on copie objet et item
wsci = wsci + 1
ws.Range("A2:B" & dls).Copy wsc.Range("C" & wsci)
wsci = wsci + dls - 2
Application.StatusBar = "phase 1 100%"
ElseIf i = 2 Then ' Ref1
For j = 3 To wsci ' on prend toutes objets et on les cherche dans Ref1
Application.StatusBar = "phase 2A " & Format(j / wsci, "0.00%")
Set re = ws.Range("F2:F" & dls).Find(wsc.Range("C" & j), lookat:=xlWhole)
If Not re Is Nothing Then
wsc.Range("A" & j) = ws.Range("B" & re.Row) & ws.Range("C" & re.Row)
wsc.Range("B" & j) = ws.Range("C" & re.Row) ' on a trouvé on copie le site et reference
Else
wsc.Range("A" & j & ":D" & j).Interior.ColorIndex = 4
End If
Next j
For j = 2 To dls
Application.StatusBar = "phase 2B " & Format(j / dls, "0.00%")
trouvé = False
Set re = wsc.Range("A3:A" & wsci).Find(ws.Range("B" & j) & ws.Range("C" & j), lookat:=xlWhole)
If re Is Nothing Then
wsci = wsci + 1
wsc.Range("A" & wsci) = ws.Range("B" & j)
wsc.Range("B" & wsci) = ws.Range("C" & j)
wsc.Range("C" & wsci) = ws.Range("F" & j)
wsc.Range("A" & wsci & ":D" & wsci).Interior.ColorIndex = 3
End If
Next j
ElseIf i = 3 Then ' perimetre
For j = 3 To wsci ' on prend toutes les ref+sites et on les recherche dans perimetre
Application.StatusBar = "phase 3 " & Format(j / wsci, "0.00%")
cle = wsc.Range("A" & j)
cle = Left(cle, Len(cle) - Len(wsc.Range("B" & j)))
With ws.Range("A2:A" & dls)
Set re = .Find(cle, lookat:=xlWhole)
trouvé = False
If Not re Is Nothing Then
Do
If ws.Range("B" & re.Row) = wsc.Range("B" & j) Then trouvé = True: Exit Do
re = .FindNext(re)
Loop Until re Is Nothing
End If
End With
If trouvé = False Then wsc.Range("A" & j & ":D" & j).Interior.ColorIndex = 6
Next j
End If
Next
Application.StatusBar = "checks done"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Set wsc = Nothing
Set ws = Nothing
End SubBonsoir,
Super cette méthode pour afficher la progression dans la barre d'état !
1) Peux-tu stp m'expliquer en 2 mots ta technique d'optimisation ? Ça fonctionne vraiment mieux !
2) J'ai peut-être détecté une régression (rien de sûr !) : j'ai fait un cas où des données sont dans Ref1, mais rien dans Ref2. Rien ne s'affiche dans Checks. Idem lorsque je place des données dans Ref2 et pas dans Ref1. Seule la couleur jaune s'affiche (quand on ne retrouve rien dans périmètre). Normal ?
Merci.
Bonjour,
Je rajoute aussi le fait que colonne A de Checks, apparaît la référence avec le site concaténé, et pas seulement la référence comme attendu. J'ai essayé de modifier le code à ce niveau :
wsc.Range("A" & j) = ws.Range("B" & re.Row) & ws.Range("C" & re.Row)par
wsc.Range("A" & j) = ws.Range("B" & re.Row)Mais ça semble perturber le reste du code, le double de lignes s'affiche, tout en jaune..
Et pour revenir sur la gestion des couleurs / checks, le code que tu as proposé le 23 Oct 2013, 11:33 fonctionnait bien sur ces points là.
Il faudrait un "mix" entre celui-là et le dernier proposé qui est optimisé + indicateur d'avancement.
bonjour,
une nouvelle version,
les optimisations consistent en
1) copier des blocs entiers de données là où c'est possible et non plus ligne par ligne, voire cellule par cellule
2) utiliser la fonction find sur des données concaténées créées temporairement, en lieu et place de 2 boucles imbriquées
Sub check()
'
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wsc = Worksheets("Checks")
' i numéro de feuille
i = 0
' wsci numéro de dernière ligne dans checks
wsci = 2
' on boucle sur les feuilles dans l'ordre
For Each wsname In Array("Ref2", "Ref1", "perimetre")
i = i + 1
Set ws = Worksheets(wsname)
dls = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
If i = 1 Then 'Ref2
Application.StatusBar = "phase 1 0%"
' on copie les colonnes objet et item en un coup
wsci = wsci + 1
ws.Range("A2:B" & dls).Copy wsc.Range("C" & wsci)
wsci = wsci + dls - 2
Application.StatusBar = "phase 1 100%"
ElseIf i = 2 Then ' Ref1
For j = 3 To wsci ' on prend toutes objets et on les cherche dans Ref1
Application.StatusBar = "phase 2A " & Format(j / wsci, "0.00%")
'on recherche l'objet (colonne C de checks) dans colonne F de ref1
Set re = ws.Range("F2:F" & dls).Find(wsc.Range("C" & j), lookat:=xlWhole)
If Not re Is Nothing Then
wsc.Range("A" & j) = ws.Range("B" & re.Row) ' on a trouvé l'objet on copie le site et reference
wsc.Range("B" & j) = ws.Range("C" & re.Row)
wsc.Range("E" & j) = ws.Range("B" & re.Row) & ws.Range("C" & re.Row) ' on crée une colonne temporaire clé fusionnée pour optimisation ultérieure
Else
wsc.Range("A" & j & ":D" & j).Interior.ColorIndex = 4 ' objet non trouvé on colorie en vert
End If
Next j
For j = 2 To dls ' on prend tous les sites de ref1 et on les cherche dans checks
Application.StatusBar = "phase 2B " & Format(j / dls, "0.00%")
trouvé = F
'on recherche reference +site ( colonnes B&C) dans colonne E(créée pour optimisation) de checks
Set re = wsc.Range("E3:E" & wsci).Find(ws.Range("B" & j) & ws.Range("C" & j), lookat:=xlWhole)
If re Is Nothing Then
wsci = wsci + 1
wsc.Range("A" & wsci) = ws.Range("B" & j)
wsc.Range("B" & wsci) = ws.Range("C" & j)
wsc.Range("C" & wsci) = ws.Range("F" & j)
wsc.Range("A" & wsci & ":D" & wsci).Interior.ColorIndex = 3 ' site non trouvé dans checks on colorie en rouge
End If
Next j
ElseIf i = 3 Then ' perimetre
For j = 2 To dls ' on crée une colonne E avec ref+site pour optimisation
Application.StatusBar = "phase 3A " & Format(j / dls, "0.00%")
ws.Range("E" & j) = ws.Range("A" & j) & ws.Range("B" & j)
Next j
For j = 3 To wsci ' on prend toutes les ref+sites de checks et on les recherche dans perimetre
Application.StatusBar = "phase 3B " & Format(j / wsci, "0.00%")
cle = wsc.Range("E" & j)
If cle <> "" Then
Set re = ws.Range("E2:E" & dls).Find(cle, lookat:=xlWhole)
If re Is Nothing Then wsc.Range("A" & j & ":D" & j).Interior.ColorIndex = 6 ' ref+site non trouvé dans périmètre on colorie en jaune
End If
Next j
' on supprime la colonne utilisée pour l'optimisation de checks perimètre
ws.Columns("E:E").Delete
End If
Next
' on supprime la colonne d'optimisation pour recherche ref1
wsc.Columns("E:E").Delete
Application.StatusBar = "checks done"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Set wsc = Nothing
Set ws = Nothing
End SubCa me paraît très bien cette fois-ci ! Le gain de temps est énorme par rapport aux premières versions.
Merci beaucoup pour ton aide. Je vais tenter de mettre en place d'autres contrôles sur ce fichier, je reviendrai peut-être vers toi si je rencontre des difficultés.
Bonne aprem.