Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

Webperegrino

XLDnaute Impliqué
Supporter XLD
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
 

Pièces jointes

  • 1_Essai Rectangles Montés Cachés.xlsm
    21.5 KB · Affichages: 4
Dernière édition:

sylvanu

XLDnaute Barbatruc
Supporter XLD
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 :
 

Pièces jointes

  • 1_Gestion couleurs entre RectanglesCaisse et Couleurs_FeuilParam ESSAI.xlsm
    56.9 KB · Affichages: 2

Webperegrino

XLDnaute Impliqué
Supporter XLD
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

XLDnaute Barbatruc
Supporter XLD
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.
 

Pièces jointes

  • Classeur2.xlsm
    14.2 KB · Affichages: 2

Webperegrino

XLDnaute Impliqué
Supporter XLD
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

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

Webperegrino

XLDnaute Impliqué
Supporter XLD
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

XLDnaute Impliqué
Supporter XLD
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

XLDnaute Impliqué
Supporter XLD
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
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…