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

Autres Utiliser un Array

Calvus

XLDnaute Barbatruc
Bonjour le forum,

Comment faire pour utiliser les valeurs d'Arrays déclarés dans une macro avec un Select Case ?

Par exemple ceci fonctionne :
VB:
Cadre1 = Array("01", "02", "03", "04")
            Select Case sh.Name
                Case "01", "02", "03", "04"

Mais si je fais appel au nom de l'Array, évidemment ça "bugue".
Code:
Cadre1 = Array("01", "02", "03", "04")
            Select Case sh.Name
                Case Cadre1

J'ai mis le code intégral dans le fichier exemple, dont le but est de colorer des groupes de shapes.
La 1ère macro fonctionne, appelant directement chaque cas
La 2nde plante pour les raisons invoquées plus haut.

Voici les 2 codes :
Code:
Sub Colorer()
Dim i As Integer, j As Integer, t, f As Worksheet, t1, f1 As Worksheet

Dim Cadre1, Cadre2, Cadre3

Cadre1 = Array("01", "02", "03", "04")
Cadre2 = Array("05", "06", "07", "08")
Cadre3 = Array("09", "10", "11", "12")

    Dim sh As Shape, couleur1, couleur2, couleur3, couleur4, couleur5
    couleur1 = RGB(180, 196, 100)
    couleur2 = RGB(180, 226, 120)
    couleur3 = RGB(140, 186, 160)
   
    For Each sh In ActiveSheet.Shapes
        If IsNumeric(sh.Name) Then
            Select Case sh.Name
                Case "01", "02", "03", "04"
                    sh.Fill.ForeColor.RGB = couleur1
                Case "05", "06", "07", "08"
                    sh.Fill.ForeColor.RGB = couleur2
                Case "09", "10", "11", "12"
                    sh.Fill.ForeColor.RGB = couleur3
            End Select
        End If
    Next sh
End Sub

Code:
Sub Colorer_2()
Dim i As Integer, j As Integer, t, f As Worksheet, t1, f1 As Worksheet

Dim Cadre1, Cadre2, Cadre3

Cadre1 = Array("01", "02", "03", "04")
Cadre2 = Array("05", "06", "07", "08")
Cadre3 = Array("09", "10", "11", "12")

    Dim sh As Shape, couleur1, couleur2, couleur3, couleur4, couleur5
    couleur1 = RGB(180, 196, 100)
    couleur2 = RGB(180, 226, 120)
    couleur3 = RGB(140, 186, 160)
   
    For Each sh In ActiveSheet.Shapes
        If IsNumeric(sh.Name) Then
            Select Case sh.Name
                Case Cadre1
                    sh.Fill.ForeColor.RGB = couleur1
                Case Cadre2
                    sh.Fill.ForeColor.RGB = couleur2
                Case Cadre3
                    sh.Fill.ForeColor.RGB = couleur3
            End Select
        End If
    Next sh
End Sub

J'aimerais évidemment utiliser le 2nd code.

Merci et bonne journée
 

Pièces jointes

  • Colorer Array.xlsm
    22.9 KB · Affichages: 14

Dranreb

XLDnaute Barbatruc
Bonjour.
Dans la mesure où les noms de Shape sont numériques et se suivent par groupes de 4, j'utiliserais leur valeur numérique :
VB:
Sub Colorer()
   Dim Sh As Shape
   For Each Sh In ActiveSheet.Shapes
      If IsNumeric(Sh.Name) Then Sh.Fill.ForeColor.RGB = Choose((Sh.Name - 1) _
         / 4 + 1, RGB(180, 196, 100), RGB(180, 226, 120), RGB(140, 186, 160))
      Next Sh
   End Sub
 

Paf

XLDnaute Barbatruc
Bonjour Calvus, Dranreb,

une autre version qui conserve les arrays, plus faciles à modifier en cas de besoin
VB:
Sub Colorer()
Dim i As Integer, j As Integer, t, f As Worksheet, t1, f1 As Worksheet
Dim sh As Shape, couleur1, couleur2, couleur3, couleur4, couleur5
Dim Cadre1, Cadre2, Cadre3

Cadre1 = Array("01", "02", "03", "04")
Cadre2 = Array("05", "06", "07", "08")
Cadre3 = Array("09", "10", "11", "12")

couleur1 = RGB(180, 196, 100)
couleur2 = RGB(180, 226, 120)
couleur3 = RGB(140, 186, 160)

With ActiveSheet
For i = 0 To 3
   . Shapes(Cadre1(i)).Fill.ForeColor.RGB = couleur1
   . Shapes(Cadre2(i)).Fill.ForeColor.RGB = couleur2
    .Shapes(Cadre3(i)).Fill.ForeColor.RGB = couleur3
Next
End With

End Sub

A+
 

Calvus

XLDnaute Barbatruc
Bonjour Paf, Dranreb,

Concernant la proposition de Dranreb, ça plante. Je n'ai pas dû trouver la bonne formule.
Voici le code
VB:
Sub Colorer_2()
Dim i As Integer, j As Integer, t, f As Worksheet, t1, f1 As Worksheet

Dim Cadre1, Cadre2, Cadre3

Cadre1 = Array("01", "02", "03", "04")
Cadre2 = Array("05", "06", "07", "08")
Cadre3 = Array("09", "10", "11", "12")

    Dim sh As Shape, couleur1, couleur2, couleur3, couleur4, couleur5
    couleur1 = RGB(180, 196, 100)
    couleur2 = RGB(180, 226, 120)
    couleur3 = RGB(140, 186, 160)
   
    For Each sh In ActiveSheet.Shapes
        If IsNumeric(sh.Name) Then
            Select Case sh.Name
                Case Application.Match(sh.Name, Cadre1, 0)
                    sh.Fill.ForeColor.RGB = couleur1
                Case Application.Match(sh.Name, Cadre2, 0)
                    sh.Fill.ForeColor.RGB = couleur2
                Case Application.Match(sh.Name, Cadre3, 0)
                    sh.Fill.ForeColor.RGB = couleur3
            End Select
        End If
    Next sh
End Sub



Concernant la solution de Paf, ça plante également si on a des noms non numériques (malgré la mise en place d'une condition) ou ne figurant pas dans les arrays..

Merci
 

Dranreb

XLDnaute Barbatruc
Pourquoi donnez vous un exemple de Shape avec noms numériques alors que dans votre application ils ne le sont pas ?
Mettez dans un un seul Array tous les noms, groupés par couleurs.
Faites Position = WorksheetFunction.Match(Sh.Name, LeTableauCommun, 0) puis Select Case Position et derrière des Case 1 To 4, puis Case 5 To 8 etc. Ou si ce sont toujours des groupes de 4 vous pouvez faire comme j'avais dit en prenant Choose((Position - 1) \ 4 + 1, …
 

patricktoulon

XLDnaute Barbatruc
bonjour
comme les nom se suivent numériquement parlant et par groupe de 4 dans cadre....... ben tu n'a pas besoins de cadre

VB:
Sub Colorer_2()
Dim i As Integer, j As Integer, t, f As Worksheet, t1, f1 As Worksheet

'Dim Cadre(1 To 3)

'Cadre(1) = "01,02,03,04"
'Cadre(2) = "05,06,07,08"
'Cadre(3) = "09,10,11,12"
    Dim sh As Shape, couleur(1 to 3)
    couleur(1) = RGB(180, 196, 100)
    couleur(2) = RGB(180, 226, 120)
    couleur(3) = RGB(140, 186, 160)
 
    For Each sh In ActiveSheet.Shapes
        If IsNumeric(sh.Name) Then
           Debug.Print sh.Name & "  " & "couleur" & Application.RoundUp(Val(sh.Name) / 4, 0)
                        sh.Fill.ForeColor.RGB = couleur(Application.RoundUp(Val(sh.Name) / 4, 0))
        End If
    Next sh
End Sub
 

Calvus

XLDnaute Barbatruc
Bonjour Patricktoulon,

Bon... merci mais j'ai fait une bêtise en mettant cet exemple. Je n'ai pas voulu mettre le code uniquement, j'ai donc fait un exemple à la va vite, voulant simplifier, sans penser que ça vous induirait tous en erreur, ma question initiale étant de vouloir savoir si on pouvait "lister" les valeurs de mes arrays.
Manifestement ce n'est pas possible.

Mon fichier original comporte plus de 400 shapes comme je l'ai dit, dont une centaine de numériques et qui ne se suivent pas, ainsi que 15 arrays.
Je n'aurais pas dû ouvrir ce fil, et vais continuer à utiliser ma méthode.

Désolé d'avoir eu à vous déranger pour rien.

Bonne journée.
 

Dranreb

XLDnaute Barbatruc
Remarque: avec 100 couleurs différentes vous pourriez avoir intérêt à les calculer à l'aide de mon objet Couleur.
Et encore, ce sera difficile d'en trouver plus de 50 qui ne se ressemblent pas trop !
Le module de classe Couleur qui définit cet objet est dans cette ressource.
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous,

Une autre méthode par mapomme en utilisant une feuille "Param". Pas besoin de code RGB, on colore directement la cellule de la ligne 1 de la couleur désirée des formes. Sous la cellule colorée, on indique les formes concernées. les modifications sont simplissimes que ce soit de couleur ou de formes rattachées à une couleur. On peut ajouter ou supprimer des groupes facilement. pas besoin de connaître de nombre de cadrei et couleuri à l'avance pour écrire le code. Le code reste fixe.

VB:
Sub Colorer()
Dim i&, j&, t, dico, xrg As Range, xcol, xcell, coul, shp

  With Sheets("Param")
    Set dico = CreateObject("scripting.dictionary")
    dico.CompareMode = TextCompare
    t = .Range("a1").CurrentRegion
    For j = 2 To UBound(t, 2)
      coul = .Cells(1, j).Interior.Color
      For i = 2 To UBound(t)
        If t(i, j) <> "" Then dico(CStr(t(i, j))) = coul
      Next i
    Next j
  End With

  Application.ScreenUpdating = False
  With Sheets("Feuil1")
    For Each shp In .Shapes: shp.Fill.ForeColor.RGB = dico(CStr(shp.Name)): Next
    .Activate
  End With
End Sub
 

Pièces jointes

  • Calvus- Colorer Array- v1a.xlsm
    20.9 KB · Affichages: 11
Dernière édition:

patricktoulon

XLDnaute Barbatruc

en fait si avec plutot un select case true et des cases match
 

patricktoulon

XLDnaute Barbatruc
re
ton post#6 corrigé
match n'a pas de catch il faut donc gérer l'erreur pour les not match et ca se passe dans un selectcase TRUE
cette methode te permet de gerer des noms no numerique et aussi un nombre diferent de nom dans chaque cadre


VB:
Sub Colorer_3()
Dim i As Integer, j As Integer, t, f As Worksheet, t1, f1 As Worksheet

Dim Cadre1, Cadre2, Cadre3

Cadre1 = Array("01", "02", "03", "04")
Cadre2 = Array("05", "06", "07", "08")
Cadre3 = Array("09", "10", "11", "12")

    Dim sh As Shape, couleur1, couleur2, couleur3, couleur4, couleur5
    couleur1 = RGB(180, 196, 100)
    couleur2 = RGB(180, 226, 120)
    couleur3 = RGB(140, 186, 160)

    For Each sh In ActiveSheet.Shapes
        If IsNumeric(sh.Name) Then
            Select Case True
                Case Not IsError(Application.Match(sh.Name, Cadre1, 0))
                    sh.Fill.ForeColor.RGB = couleur1
                Case Not IsError(Application.Match(sh.Name, Cadre2, 0))
                    sh.Fill.ForeColor.RGB = couleur2
                Case Not IsError(Application.Match(sh.Name, Cadre3, 0))
                    sh.Fill.ForeColor.RGB = couleur3
            End Select
        End If
    Next sh
End Sub

explication
VB:
'si le match est négatif ca plante
Case Application.Match(sh.Name, Cadre1, 0)
                    sh.Fill.ForeColor.RGB = couleur1

VB:
'si le match est negatif ca ne fait rien (ce qu'est sensé faire un select case )
Case Not IsError(Application.Match(sh.Name, Cadre1, 0))

                    sh.Fill.ForeColor.RGB = couleur1
le"iserror(.......) gere en meme temps les erreur de catch non gér"s par match et transforme la valeur en booleene
conclusion selectcase true
 
Dernière édition:

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…