XL 2010 Couleur VBA

DIDPROJ · 19 Mai 2020

Bonjour à tous,

J'ai une question. J'ai fait un planning pour ma société.
Lorsque je rentre des horaires dans les colonnes H et I , il s'affiche par macro la plage horaire avec le nom du déplacement.
La couleur de la plage horaire correspond à la couleur du nom de la personne dans la colonne B.

Pour mettre les couleurs à jour il faut que je clique sur le bouton couleur.

Par contre il n'y a que les couleurs pour la date du lundi qui se mettent à jour. Je n'arrive pas a appliquer cette fonction à l'ensemble de mon tableau.

Pouvez vous m'aider sur ce point : je voudrais que l'ensemble des couleurs des plages horaires de mon tableau correspondent à la couleur des noms correspondant.
Il y a déjà une macro dans le module 1 que j'essaye de modifier mais en vain et je vous joins mon fichier.

D'avance merci à tous

sylvanu · 19 Mai 2020

Bonjour DidProj, Fred0o,
Et en passant par un transfert dans un array et en optimisant la taille de celui ci , on passe de 1.93s à 0.14s.

sylvanu · 19 Mai 2020

Bonjour DidProj,
Evidemment quand on fait :

VB:

 If .Cells(j, 2) = "" Then Exit Sub

et que pour le mardi la cellule B est vide puisque la date est en A, on sort de la Sub. Donc on ne traite que le lundi.
En PJ un essai.
J'en ai profité pour limiter le nombre de lignes à traiter en essayant d'évaluer le nombre de lignes en tenant compte des jours et de l'entête.
Et j'ai aussi accéléré en sautant tous les IF si la cellule en B est vide.

sylvanu · 19 Mai 2020

Dans la même idée d’accélérer le processus, on peut avantageusement remplacer tous ces IF par des CASE.
En appuyant sur Couleurs, sur mon PC on passe de 1.93s avec les IF contre 0.37s avec les Case.

Fred0o · 19 Mai 2020

Bonjour DIDPROJ

Il faut TOUJOURS se mefier des cellules fusionnees. J'ai supprime une ligne fusionnee qui ne servait a rien dans le tableau a chaque date et adapte le code :

VB:

Sub couleurs_noms()
    Dim j As Long, k As Long
    Application.ScreenUpdating = False
    With Sheets("Planning")
        For j = 11 To 10000
            For k = 10 To 34
                If .Cells(j, 1) = "" And .Cells(j, 2) = "" Then Exit Sub
                If .Cells(j, 2) = "Fabrice FONTAINE" And .Cells(j, k).Interior.ColorIndex <> xlNone Then
                    .Cells(j, 2).Font.ColorIndex = 5
                    .Cells(j, k).Interior.ColorIndex = 5
                ElseIf .Cells(j, 2) = "Stéphane POCHET" And .Cells(j, k).Interior.ColorIndex <> xlNone Then
                    .Cells(j, 2).Font.ColorIndex = 44
                    .Cells(j, k).Interior.ColorIndex = 44
                ElseIf .Cells(j, 2) = "Christophe ANSELIN" And .Cells(j, k).Interior.ColorIndex <> xlNone Then
                    .Cells(j, 2).Font.ColorIndex = 4
                    .Cells(j, k).Interior.ColorIndex = 4
                ElseIf .Cells(j, 2) = "Isabelle POCHET" And .Cells(j, k).Interior.ColorIndex <> xlNone Then
                    .Cells(j, 2).Font.ColorIndex = 7
                    .Cells(j, k).Interior.ColorIndex = 7
                ElseIf .Cells(j, 2) = "Françoise GALLET" And .Cells(j, k).Interior.ColorIndex <> xlNone Then
                    .Cells(j, 2).Font.ColorIndex = 46
                    .Cells(j, k).Interior.ColorIndex = 46
                ElseIf .Cells(j, 2) = "Didier MARQUOIS" And .Cells(j, k).Interior.ColorIndex <> xlNone Then
                    .Cells(j, 2).Font.ColorIndex = 29
                    .Cells(j, k).Interior.ColorIndex = 29
                End If
            Next k
        Next j
    End With
    Application.ScreenUpdating = True
End Sub

sylvanu · 19 Mai 2020

Bonjour DidProj, Fred0o,
Et en passant par un transfert dans un array et en optimisant la taille de celui ci , on passe de 1.93s à 0.14s.

DIDPROJ · 19 Mai 2020

Merci a vous c'est nikel.

Il n'y a pas a dire le VBA c'est une chose à part...

Merci

sylvanu · 19 Mai 2020

Ce que vous aviez fait marché. Exceptées ces fichues cellules fusionnées.
Après ce n'est que de l'optimisation.

XL 2010 Couleur VBA

DIDPROJ

XLDnaute Nouveau

Pièces jointes

sylvanu

sylvanu

XLDnaute Barbatruc

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

Fred0o

XLDnaute Barbatruc

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

DIDPROJ

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Discussions similaires