XL 2016 Montrer ou cacher deux familles de rectangles (seulement) sur une feuille

Webperegrino · 1 Juillet 2023

Bonjour Le Forum,

Je cherche une alternance d’affichage de deux familles de Rectangles Jaunes et Verts, que je voudrais superposer ultérieurement.
Cette alternance se fera avec le choix de valeur dans la cellule G3.

J'ai un problème dans mon "Private Sub Worksheet_change(ByVal Target As Range)".

Ma variante de conception avec les deux boutons Masquer et Afficher (que je devrai supprimer de mon application) ne fonctionne pas non plus. J'avais essayé cette parade, le problème c'est que les rectangles bleus disparaissent aussi.

Pouvez-vous m’aider à corriger ma partie «"Private Sub Worksheet_change » ? ... pour que seulement les deux familles de rectangles Jaunes et Verts alternent dans l’affichage,
Merci

Webperegrino

sylvanu · 3 Juillet 2023

Re,
Avant votre message #11, je m'étais attelé à minimiser les scintillements écran lors des choix sur G2, je trouve ça très désagréable.
Ce qui suit n'a rien à voir avec le souci qui vous pré occupe, c'est du cosmétique pour plus tard.

En fait, j'ai trouvé quatre astuces permettant de supprimer ces scintillements :
1- En début de macro, si la cellule est vide, on sort
2- En groupant les shapes par type GroupeFixes et GroupeAmbulants, on évite les boucles de masquage
3- On supprime les Application.ScreenUpdating = True superflus
4- On ajoute Application.EnableEvents = False et True, car quand on modifie G2 alors on re rentre dans la boucle
En plus ça simplifie le code :

VB:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target = "" Then Exit Sub
If Not Intersect(Target, [G2]) Is Nothing Then
  If Target = "FIXES" Then Flag = False Else Flag = True
    Application.EnableEvents = False
    ActiveSheet.Shapes("GroupeFixes").Visible = Flag
    ActiveSheet.Shapes("GroupeAmbulants").Visible = Not (Flag)
    If Target = "AMBULANTS" Then Target = "FIXES" Else Target = "AMBULANTS"
    If Target = "AMBULANTS" Then [Q2] = "Amb" Else [Q2] = "Fixe"
    [A1].Select
    Application.EnableEvents = True
  End If
Exit Sub

Quand à votre souci, vous n'avez pas répondu :

sylvanu à dit:
Quel est le but de la manip ?
Appliquer les couleurs de Paramètres sur les shapes de la feuille Caisse ?
Mais dans ce cas pourquoi ne pas le faire quand on modifie la feuille Paramètres, une fois pour toute.
On n'a pas à changer les couleurs de la feuille Caisse lorsqu'on est sur celle ci, mais uniquement lorsqu'on change les couleurs de la feuille Parametres.

Webperegrino · 3 Juillet 2023

Le Forum,
Re-Sylvanu,
Merci beaucoup pour la proposition "cosmétique" #16 ; en effet c'est vraiment plus propre.

Pour faire appliquer les couleurs de la colonne AA de Paramètres dans les Rectangles "AMBULANTS" de la feuille Caisse, j'ai aussi tenté avec ce qui me pose souci entre les '*******, mais sans succès :

VB:

Couleur = Target.Interior.Color
' For n = 1 To Dr1: ActiveSheet.Shapes("Rectangle " & n).Fill.ForeColor.RGB = Couleur: Next n
For n = 1 To Dr2
Couleur = Par.Range("AA" & n).Interior.Color

'*****************
If Par.Range("AA" & n) = ActiveSheet.Shapes("Rectangle " & n + Dr1).TextRange.Text Then
'*****************
ActiveSheet.Shapes("Rectangle " & n + Dr1).Fill.ForeColor.RGB = Par.Range("AA" & n).Couleur
End If
Next n

Merci pour la formation sur les rectangles en "Groupes" ; j'ai appliqué et c'est parfait pour cette partie de codes.
Cordialement,
Webperegrino

sylvanu · 3 Juillet 2023

Hors contexte, difficile d'analyser.
Quand vous avez un souci de ce genre, très surement un problème de syntaxe, faites un petit fichier test.
Cela permet d'isoler le problème.
Par ex voir PJ :

VB:

Range("H8") = ActiveSheet.Shapes("Rectangle").TextRange.Text

ne marche pas.

Code:

Range("H8") = ActiveSheet.Shapes("Rectangle").TextFrame2.TextRange.Text

marche.

Mais pas sur que le problème ne vienne que de là, il y a d'autres paramètres comme dR1, dR2 qui peuvent poser souci.

Webperegrino · 3 Juillet 2023

Merci Sylvanu,
Je vais étudier cela.
Je trouve que déjà, au niveau où vous m'avez élevé, je dois m'estimer heureux. Et c'est le cas !

Je continue à rechercher (je n'ai pas mieux en mettant ".textFrame.Characters.Text" Then...), mais ça ne bloque plus la macro, sans pour autant mettre à jour la couleur des Rectangles "AMBULANTS" dans la Feuille Caisse.

Meric beaucoup,
Webperegrino

sylvanu · 3 Juillet 2023

Ca va être difficile de vous aider, je n'ai toujours pas saisi la manip exacte que vous vouliez faire.

sylvanu à dit:
Quel est le but de la manip ?
Appliquer les couleurs de Paramètres sur les shapes de la feuille Caisse ?
Mais dans ce cas pourquoi ne pas le faire quand on modifie la feuille Paramètres, une fois pour toute.
On n'a pas à changer les couleurs de la feuille Caisse lorsqu'on est sur celle ci, mais uniquement lorsqu'on change les couleurs de la feuille Parametres.

Webperegrino · 3 Juillet 2023

Sylvanu,
Par exemple :
Quand je clique sur G2 pour faire paraître le Groupe AMBULANTS, le Rectangle Haut-Gauche n° 2 "AMBULANT / 10:00 - 13:00 / Sect 1 - Kl..." aurait dû changer en couleur selon celle qui est dans la cellule AA5 de la feuille Paramètres.
C'est-à-dire adopter la couleur Interior 35, Un font -4105, un RGB de 216,228,188

Webperegrino · 3 Juillet 2023

Le Forum,
Sylvanu,
Je m'en suis sorti en mettant ceci en fin de macro :

VB:

If Par.[AB1] = "" Then
For n = 1 To Dr2
n1 = Dr1 + n
' Couleur = Par.Range("AA" & n).Interior.ColorIndex '.Interior.Color '.RGB
Ftx = Right(Par.Range("AA" & n + 1), 2)
If Ftx = Right(ActiveSheet.Shapes("Rectangle " & n1).TextFrame.Characters.Text, 2) Then 'TextFrame.Characters.Text
If Ftx = "de" Then ActiveSheet.Shapes("Rectangle " & n1).Fill.ForeColor.RGB = RGB(255, 192, 0)
If Ftx = "er" Then ActiveSheet.Shapes("Rectangle " & n1).Fill.ForeColor.RGB = RGB(217, 217, 217)
If Ftx = "K2" Then ActiveSheet.Shapes("Rectangle " & n1).Fill.ForeColor.RGB = RGB(191, 191, 191)
If Ftx = "xe" Then ActiveSheet.Shapes("Rectangle " & n1).Fill.ForeColor.RGB = RGB(216, 228, 188)
If Ftx = "ue" Then ActiveSheet.Shapes("Rectangle " & n1).Fill.ForeColor.RGB = RGB(218, 238, 243)
If Ftx = "es" Then ActiveSheet.Shapes("Rectangle " & n1).Fill.ForeColor.RGB = RGB(197, 217, 241)
If Ftx = "ZH" Then ActiveSheet.Shapes("Rectangle " & n1).Fill.ForeColor.RGB = RGB(141, 180, 226)
Par.[AB1] = "MAJ"
End If
Next n
End If

J'ai honte mais ça a fonctionné !
Merci Sylvanu pour toute votre aide et votre persévérance envers moi : "ça fait plaisir" comme me le dit souvent ma fille qui est stationnée à Montréal...
Webperegrino

Webperegrino · 8 Juillet 2023

Le Forum,
Sylvanu,
Bonsoir,
Après quelques journées de cogitations, j'ai enfin réussi à suivre vos recommandations et trouver ce qu'il me fallait pour placer :
- le texte,
- la couleur du texte,
- la couleur de fond...
dans les Shapes ("Rectangle " & n) à partir des cellules de la feuille Paramètres.
Merci encore pour votre soutien.
Ci-dessous ma trouvaille qui est le résultat de votre précieuse aide.
Cordialement,
Webperegrino

VB:

Sub CouleurTextesFonds()
'grâce à l'aide de SYLVANU
'Procédure pour mise en couleur des rectangles Fixes
'Mettre à jour le texte des Rectangles FIXES avec Par.[V2 à 45 maxi]
Set Par = Sheets("Paramètres")
Sheets("Caisse").Select
If Par.[AB1] = "Couleur" And [G2] = "FIXES" Then
  For n = 2 To Par.[V45].End(xlUp).Row
     'met le texte
     ActiveSheet.Shapes("Rectangle " & n - 1).TextFrame2.TextRange.Text = Par.Range("V" & n).Value
     'met la bonne couleur dans le Rectangle
     ActiveSheet.Shapes("Rectangle " & n - 1).Fill.ForeColor.RGB = Par.Range("V" & n).Interior.Color
    'met la couleur de police
    If Par.Range("V" & n).Font.Color = RGB(0, 0, 0) Then ActiveSheet.Shapes("Rectangle " & n - 1).Fill.BackColor.RGB = RGB(0, 0, 0)
    If Par.Range("V" & n).Font.Color = RGB(255, 255, 255) Then ActiveSheet.Shapes("Rectangle " & n - 1).Fill.BackColor.RGB = RGB(255, 255, 255)
  Next n
  Par.[AB1] = "MAJ Couleurs"
End If
End Sub

XL 2016 Montrer ou cacher deux familles de rectangles (seulement) sur une feuille

Webperegrino

XLDnaute Impliqué

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

Webperegrino

XLDnaute Impliqué

sylvanu

XLDnaute Barbatruc

Pièces jointes

Webperegrino

XLDnaute Impliqué

sylvanu

XLDnaute Barbatruc

Webperegrino

XLDnaute Impliqué

Webperegrino

XLDnaute Impliqué

Webperegrino

XLDnaute Impliqué

Discussions similaires