accélérer un code vba xl 2003

[gosselien]

Bonjour,

j'ai un problème relativement simple mais je ne trouve pas de solution rapide (Xl 2003):

ma colonne C contient des codes articles alphanumériques uniques ou pas (+/- 50.000) dont une grande partie colorées (par le pot de peinture et non en MFC); j'aimerais dans une colonne voisine avoir le code interior.colorindex ET que la couleur de la cellule de la colonne C soit reproduite dans la colonne voisine en vue de trier par couleur.
La boucle for next que j'ai fais prend un temps fou et je me demande sil n'est pas possible de passer par un(e) array ?

Merci de votre aide

 

[Cousinhub]

Re : accélérer un code vba xl 2003

Bonsoir,

Peut-être en utilisant un objet "Dictionary"?

Comme ceci :

Sub Filtre_Couleur_2003()
Dim Cel As Range
Dim DerLig As Long
Dim Couleurs As Object
Set Couleurs = CreateObject("Scripting.Dictionary")
DerLig = Cells(Rows.Count, 3).End(xlUp).Row
For Each Cel In Range("C2:C" & DerLig)
    Couleurs(Cel.Row) = Cel.Interior.ColorIndex
Next Cel
Range("D2").Resize(Couleurs.Count) = Application.Transpose(Couleurs.items)
End Sub

Bon courage

 

[job75]

Re : accélérer un code vba xl 2003

Bonsoir gosselien, salut bh2, heureux de te croiser,

S'il s'agit uniquement de trier les couleurs :

Sub TrierCouleur()
Set P = Range("A2:D" & Cells(Rows.Count, 3).End(xlUp).Row) 'plage à adapter
ThisWorkbook.Names.Add "couleur", RefersToR1C1:="=GET.CELL(38,RC[-1])"
P.Columns(4) = "=couleur"
P.Columns(4) = P.Columns(4).Value 'supprime les formules
P.Sort P(1, 4), Header:=xlNo
P.Columns(4).ClearContents 'facultatif
ThisWorkbook.Names("couleur").Delete 'facultatif
End Sub

J'ai supposé que le tableau à trier occupe les colonnes A:C et qu'il y a des titres en ligne 1.

A+

 

[solquagerius]

Re : accélérer un code vba xl 2003

Salut !
Je ne sais pas si tu as résolu ton problème, mais si je peux donner un conseil :
- les formules c'est bien si y'en a pas beaucoup, sinon ça prend beaucoup de place pour rien si on peut le faire par macro. Pour 50 000 lignes, je conseillerais de ne pas en mettre.
- Pour accélérer le code de bhbh, insérer une instruction pour désactiver le rafraichissement automatique : application.screenupdating = false (desactiver) et =true à la fin du code pour réactiver.

A+

 

[Cousinhub]

Re : accélérer un code vba xl 2003

Hi,

@ Job : Félicitations.....

Sur 45000 lignes, ton code est 3 fois plus rapide (0.24 contre 0.64 s)

J'aurais jamais pensé qu'une macro xl4 soit si rapide....tout en sachant qu'un objet "Dictionary" est déjà très rapide....

Je note

Bon W-E et passe de joyeuses fêtes

Hub

 

[job75]

Re : accélérer un code vba xl 2003

Bonsoir solquagerius,

Le code de bhbh ne modifie la feuille qu'une seule fois, lors de la restitution finale.

Application.ScreenUpdating = False n'aura donc guère d'effet.

A+

 

[gosselien]

Re : accélérer un code vba xl 2003

récapitulation:

Application.ScreenUpdating = False je l'avais mis...ainsi que le recalcul auto changé en manuel

@job75: que dois-je comprendre par " RefersToR1C1:="=GET.CELL(38,RC[-1])" , ça plante à cet endroit
38 = la ligne ?
pour info; la colonne concernée va de C1 à C58000 et l'info colorindex ET la couleur doivent être dans une colonne voisine , le code de bhbh va vite mais les cellules de la colonne voisine , si elles ont bien le code couleur, elles n'ont pas la couleur de fond identique à ma colonne C c'eut été un plus.

pour ce qui est des formules dans le vrai tableau, elles sont mises de côté en y ajoutant des "" pour les transformer en texte provisoirement, des guillemets que je retire quand j'ai fais qq modif importantes dans le fichier.
on ne sait donc pas mettre les couleurs en mémoire comme des valeurs si je comprends ...

 

[Cousinhub]

Re : accélérer un code vba xl 2003

Re-,

Avec mon code, cela donnerait :

Sub Filtre_Couleur_2003()
Dim Cel As Range, Plg As Range
Dim DerLig As Long
Dim Couleurs As Object
Application.ScreenUpdating = False
t = Timer
Set Couleurs = CreateObject("Scripting.Dictionary")
DerLig = Cells(Rows.Count, 3).End(xlUp).Row
Set Plg = Range("C2:C" & DerLig)
For Each Cel In Range("C2:C" & DerLig)
    Couleurs(Cel.Row) = Cel.Interior.ColorIndex
Next Cel
Range("D2").Resize(Couleurs.Count) = Application.Transpose(Couleurs.items)
Range("A2:D" & DerLig).Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlNo
Plg.Copy
Plg.Offset(, 1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
MsgBox Timer - t
End Sub

et avec celui de Job :

Sub TrierCouleur()
Application.ScreenUpdating = False
t = Timer
Set p = Range("A2:D" & Cells(Rows.Count, 3).End(xlUp).Row) 'plage à adapter
ThisWorkbook.Names.Add "couleur", RefersToR1C1:="=GET.CELL(38,RC[-1])"
p.Columns(4) = "=couleur"
p.Columns(4) = p.Columns(4).Value 'supprime les formules
p.Sort p(1, 4), Header:=xlNo
'p.Columns(4).ClearContents 'facultatif
ThisWorkbook.Names("couleur").Delete 'facultatif
p.Columns(3).Copy
p.Columns(4).PasteSpecial Paste:=xlPasteFormats
MsgBox Timer - t
End Sub

Maintenant, pourquoi cela ne marche pas chez toi????

Peut-être que les Mac n'acceptent pas les macros xl4?

Bon courage

 

[gosselien]

Re : accélérer un code vba xl 2003

en attendant j'ai essayé ceci:

Sub Filtre_Couleur_2003()
Dim Cel As Range
Dim DerLig As Long
Dim Couleurs As Object
Dim T
Dim start_time: start_time = Timer
Set Couleurs = CreateObject("Scripting.Dictionary")
DerLig = Cells(Rows.Count, 3).End(xlUp).Row
For Each Cel In Range("C2:C" & DerLig)
Couleurs(Cel.Row) = Cel.Interior.ColorIndex
Next Cel
Range("N2").Resize(Couleurs.Count) = Application.Transpose(Couleurs.items)
Dim Plage
Set Plage = Range("N2", [N65000].End(xlUp))
For Each C In Plage
C.Interior.ColorIndex = C.Offset(0, -11).Interior.ColorIndex
Next
MsgBox Str(Timer - start_time) + " secondes " ' 12,5 secondes sur mon vieux pc
End Sub

sous windows XP Excel 2003 ACer 2.Ghz, pour le fun je testerai sur mon mac + récent...

je regarde à ton code ensuite bhbh, merci déjà

 

[gosselien]

Re : accélérer un code vba xl 2003

tourne pas sur mon MAC à cause de ceci, mais pas grave au boulot je suis aussi en XP et 2003

Set Couleurs = CreateObject("Scripting.Dictionary") ' un composant active X ne peut pas créer d'objet...

Merci à tous, je vais adapter ça à mon fichier de travail
bon week end

 

[job75]

Re : accélérer un code vba xl 2003

Re,

38 = la ligne ?

GET.CELL c'est la fonction macro Excel 4.0 LIRE.CELLULE.

Elle permet de renvoyer les valeurs de beaucoup de propriétés d'une cellule.

LIRE.CELLULE(38;référence) renvoie la couleur de fond de la cellule référence.

Bonne nuit.

 

[gosselien]

Re : accélérer un code vba xl 2003

Re,



GET.CELL c'est la fonction macro Excel 4.0 LIRE.CELLULE.

Elle permet de renvoyer les valeurs de beaucoup de propriétés d'une cellule.

LIRE.CELLULE(38;référence) renvoie la couleur de fond de la cellule référence.

Bonne nuit.

merci pour l'info...
je vais retester ça à l'occasion, vos 2 codes sont extremements rapides...
bon week end

 

[job75]

Re : accélérer un code vba xl 2003

Bonjour le fil, le forum,

La méthode Dictionary de bhbh me laissait perplexe car ici elle ne sert pas à éliminer les doublons.

J'ai donc comparé ces 3 macros sur 60000 lignes :

Sub TrierCouleur_Dictionary() '1,56 seconde sur 60000 lignes
Dim t#, P As Range, coul As Object, i&
t = Timer
Set P = Range("A2:D" & Cells(Rows.Count, 3).End(xlUp).Row) 'plage à adapter
Set coul = CreateObject("Scripting.Dictionary")
For i = 1 To P.Rows.Count
  coul(i) = P(i, 3).Interior.ColorIndex
Next
P(1, 4).Resize(coul.Count) = Application.Transpose(coul.items)
P.Sort P(1, 4), Header:=xlNo
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Sub TrierCouleur_Tableau() '1,33 seconde sur 60000 lignes
Dim t#, P As Range, coul, i&
t = Timer
Set P = Range("A2:D" & Cells(Rows.Count, 3).End(xlUp).Row) 'plage à adapter
coul = P.Columns(4)
For i = 1 To P.Rows.Count
  coul(i, 1) = P(i, 3).Interior.ColorIndex
Next
P(1, 4).Resize(UBound(coul)) = coul
P.Sort P(1, 4), Header:=xlNo
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

Sub TrierCouleur_Excel4() '0,72 seconde sur 60000 lignes
Dim t#, P As Range
t = Timer
Set P = Range("A2:D" & Cells(Rows.Count, 3).End(xlUp).Row) 'plage à adapter
ThisWorkbook.Names.Add "couleur", RefersToR1C1:="=GET.CELL(38,RC[-1])"
P.Columns(4) = "=couleur"
P.Columns(4) = P.Columns(4).Value 'supprime les formules
P.Sort P(1, 4), Header:=xlNo
MsgBox "Durée " & Format(Timer - t, "0.00 \s")
End Sub

La méthode Dictionary est un peu moins rapide qu'un simple tableau VBA.

Fichier joint.

A+

 

[gosselien]

Re : accélérer un code vba xl 2003

après essai (sur excel 2003), excel 2007 et 2010 (mac) le code excel4 ne fonctionne pas ; il indique "=couleur" dans toute la colonne D...

les temps de réalisation sont très proches , vous êtes forts :=)

 

[job75]

Re : accélérer un code vba xl 2003

Re,

après essai (sur excel 2003), excel 2007 et 2010 (mac) le code excel4 ne fonctionne pas ; il indique "=couleur" dans toute la colonne D...

Vérifiez que la colonne D n'est pas au format "Texte", il faut le format "Standard"...

A+