Microsoft 365 Afficher /Masquer Shapes selon leurs valeurs

pat66

XLDnaute Impliqué
Bonjour le forum,

j'ai un problème et toute aide serait la bienvenue, à savoir : Ne voir que les shapes dont les valeurs sont comprises entre 2 autres valeurs saisies en E6 et H6, en précisant que si E6 ou H6 sont vides, les shapes sont toutes masquées

ci joint un exemple concret afin d'être mieux compris

merci d'avance pour votre collaboration

cdt
 

Pièces jointes

  • Classeur1.xlsm
    12.2 KB · Affichages: 6
Dernière édition:
Solution
Salut, teste ceci. Je me suis basé sur ton exemple, donc tes shapes se nomment "Rectangle" et tes valeurs sont situées dans la plage A18:A26. Modifie si besoin.

VB:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim shp As Shape
    Dim i As Integer
    Dim cellValue As Double
    Dim lowerLimit As Variant
    Dim upperLimit As Variant

    Set ws = ThisWorkbook.Sheets("Feuil1")
    lowerLimit = ws.Range("E6").Value
    upperLimit = ws.Range("H6").Value

    ' Vérifie si la modification a eu lieu dans la plage des valeurs
    If Intersect(Target, Union(ws.Range("A18:A26"), ws.Range("E6"), ws.Range("H6"))) Is Nothing Then Exit Sub

    'Si E6 et H6 vides
    If IsEmpty(lowerLimit) Or IsEmpty(upperLimit)...

Franc58

XLDnaute Occasionnel
Salut, teste ceci. Je me suis basé sur ton exemple, donc tes shapes se nomment "Rectangle" et tes valeurs sont situées dans la plage A18:A26. Modifie si besoin.

VB:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim shp As Shape
    Dim i As Integer
    Dim cellValue As Double
    Dim lowerLimit As Variant
    Dim upperLimit As Variant

    Set ws = ThisWorkbook.Sheets("Feuil1")
    lowerLimit = ws.Range("E6").Value
    upperLimit = ws.Range("H6").Value

    ' Vérifie si la modification a eu lieu dans la plage des valeurs
    If Intersect(Target, Union(ws.Range("A18:A26"), ws.Range("E6"), ws.Range("H6"))) Is Nothing Then Exit Sub

    'Si E6 et H6 vides
    If IsEmpty(lowerLimit) Or IsEmpty(upperLimit) Then
        'Parcourt tous les shapes et les masque
        For i = 1 To 9
            Set shp = ws.Shapes("Rectangle " & i)
            shp.Visible = msoFalse
        Next i
    Else
        'Sinon parcourt tous les shapes
        For i = 1 To 9
            Set shp = ws.Shapes("Rectangle " & i)
            cellValue = ws.Range("A" & i + 17).Value
            'et compare valeur en A avec E6 et H6
            If cellValue < lowerLimit Or cellValue > upperLimit Then
                shp.Visible = msoFalse
            Else
                shp.Visible = msoTrue
            End If
        Next i
    End If
End Sub
 

pat66

XLDnaute Impliqué
Bonsoir,

c'est tout simplement parfait, je te remercie beaucoup...

A partir de ta solution j'ai essayé de réaliser la même chose avec d'autres shapes, mais je n'y arrive pas, pourrais tu m'aider à modifié ta solution dans ce sens, je te remercie par avance pour ton aide et ta compréhension

voir exemple ci joint complété
 

Pièces jointes

  • Classeur1-complet.xlsm
    21.4 KB · Affichages: 3
Dernière édition:

pat66

XLDnaute Impliqué
mêmes cellules que pour A18, cad Miminum =E6 Maximum H6
exemple
A18 = 100 et B18 = 10, Si le shapes supérieur s'affiche alors le shape inférieur s'affiche aussi
A19 = 150 et B19 = 11, idem
etc....
 
Dernière édition:

Franc58

XLDnaute Occasionnel
OK, mais comme les 2 séries de shapes n'ont pas le même ordre de grandeur, en fonction de min et max, une de 2 séries sera toujours complètement masquée.

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim shp As Shape
    Dim i As Integer
    Dim cellValue As Double
    Dim lowerLimit As Variant
    Dim upperLimit As Variant

    Set ws = ThisWorkbook.Sheets("Feuil1")
    lowerLimit = ws.Range("E6").Value
    upperLimit = ws.Range("H6").Value

    ' Vérifie si la modification a eu lieu dans une cellule d'intérêt
    If Intersect(Target, Union(ws.Range("A18:A26"), ws.Range("B18:B26"), ws.Range("E6"), ws.Range("H6"))) Is Nothing Then Exit Sub

    'Si E6 et H6 vides
    If IsEmpty(lowerLimit) Or IsEmpty(upperLimit) Then
        'Parcourt tous les shapes et les masque
        For i = 1 To 18
            Set shp = ws.Shapes("Rectangle " & i)
            shp.Visible = msoFalse
        Next i
    Else
        'Sinon parcourt tous les shapes
        For i = 1 To 9
            Set shp = ws.Shapes("Rectangle " & i)
            cellValue = ws.Range("A" & i + 17).Value
            'et compare valeur en A avec E6 et H6
            If cellValue < lowerLimit Or cellValue > upperLimit Then
                shp.Visible = msoFalse
            Else
                shp.Visible = msoTrue
            End If
        Next i
        For i = 10 To 18
            Set shp = ws.Shapes("Rectangle " & i)
            cellValue = ws.Range("B" & i + 8).Value
            'et compare valeur en B avec E6 et H6
            If cellValue < lowerLimit Or cellValue > upperLimit Then
                shp.Visible = msoFalse
            Else
                shp.Visible = msoTrue
            End If
        Next i
    End If
End Sub
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
313 329
Messages
2 097 234
Membres
106 883
dernier inscrit
Papalo