Code VBA non fonctionnel: Activesheet n'est pas retrouvée

Version imprimable

Bonjour,

J'ai essayé d'utiliser le code ci-dessous récupéré via un tuto mais je bute sur la sélection des formes dnas la feuille active. peuPeut être pouvez vous m'aider.
Merci+++

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
'*********************************************************************************************************************
' Procédure permettant de rendre une carte dynamique à partir de plusieurs critères.
'*********************************************************************************************************************
 
Sub AfficheCouleurMap()
'déclaration des variables
Dim i As Integer
Dim RegMax As Integer
 
'Affectation des variables
RegMax = WorksheetFunction.CountA(Sheets("Calcul").Range("A:A")) + 1
 
'Boucle permettant de récupérer les différentes régions de la table source
 
For i = 4 To RegMax
 
'on récupere les noms des départements dans une zone nommée
Range("actDept").Value = Range("Calcul!A" & i).Value
 
'on sélectionne chacun des départements de la carte (formes/shapes) ayant le même nom
'ActiveSheet.Shapes(Range("actDept").Value).Select
 
 
'on affecte une couleur à la forme en fonction du critère défini (prévalence glaucome, glaucome traité, non-observance, glaucome non traité)
 
Selection.ShapeRange.Fill.ForeColor.RGB = Range(Range("actDeptCode")).Value.Interior.Color
 
 
Next i
'on se positionne en K2 au niveau de la liste Box
Range("K2").Select
 
 
End Sub

30/10/2018, 13h18
Igloobel

1 pièce(s) jointe(s)

Bonjour,

tout d'abord met ton code sous balise CODE (grace au bouton #)

vu que

Code:

'ActiveSheet.Shapes(Range("actDept").Value).Select

est en commentaire tu n'as pas de selection

de plus les selects c'est pas le plus performant

en fin les shapes peuvent avoir différentes formes comme :

Pièce jointe 423249

Es-tu sur qu'il n'y a pas d'autres types de Shapes qui traines ...

de plus ton shapes es de quel type :

A+
30/10/2018, 13h31
SAK78

les objets sont des départements que j'ai nommés de leur nom.
l'erreur est sur ActiveSheet.Shapes(Range("actDept").Value).Select et Selection.ShapeRange.Fill.ForeColor.RGB = Range(Range("actDeptCode")).Value.Interior.Color.

Citation:

erreur d'exécution: '-2147024809(800757)

J'ai rectifié le commentaire sans succès!

Bon execute ce code et montre le Msgbox obtenu

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
Sub Recense_Shapes()
    Dim Shp As Shape
    Dim Wsh As Worksheet
    Dim Tab_Shapes(1 To 2, 1 To 25) As Variant
    Dim Mess As String
    Dim i As Byte
 
    For i = 1 To 25
        Tab_Shapes(1, i) = 0
        Tab_Shapes(2, i) = ""
    Next
    Mess = "Pour le classeur " & ActiveWorkbook.Name & vbCrLf & vbCrLf & _
        "Les Objets Shapes recensés sont : " & vbCrLf & vbCrLf
 
 
    For Each Wsh In ActiveWorkbook.Worksheets
        Wsh.Activate
        For Each Shp In ActiveSheet.Shapes
            Select Case Shp.Type
                Case -2
                    Tab_Shapes(1, 1) = Tab_Shapes(1, 1) + 1
                    Tab_Shapes(2, 1) = "Type de forme mixte"
                Case 1
                    Tab_Shapes(1, 2) = Tab_Shapes(1, 2) + 1
                    Tab_Shapes(2, 2) = "Forme automatique"
                Case 2
                    Tab_Shapes(1, 3) = Tab_Shapes(1, 3) + 1
                    Tab_Shapes(2, 3) = "Légende"
                Case 3
                    Tab_Shapes(1, 4) = Tab_Shapes(1, 4) + 1
                    Tab_Shapes(2, 4) = "Graphique"
                Case 4
                    Tab_Shapes(1, 5) = Tab_Shapes(1, 5) + 1
                    Tab_Shapes(2, 5) = "Commentaire"
                Case 5
                    Tab_Shapes(1, 6) = Tab_Shapes(1, 6) + 1
                    Tab_Shapes(2, 6) = "Forme libre"
                Case 6
                    Tab_Shapes(1, 7) = Tab_Shapes(1, 7) + 1
                    Tab_Shapes(2, 7) = "Groupe"
                Case 7
                    Tab_Shapes(1, 8) = Tab_Shapes(1, 8) + 1
                    Tab_Shapes(2, 8) = "Objet OLE incorporé"
                Case 8
                    Tab_Shapes(1, 9) = Tab_Shapes(1, 9) + 1
                    Tab_Shapes(2, 9) = "Contrôle de formulaire"
                Case 9
                    Tab_Shapes(1, 10) = Tab_Shapes(1, 10) + 1
                    Tab_Shapes(2, 10) = "Trait"
                Case 10
                    Tab_Shapes(1, 11) = Tab_Shapes(1, 11) + 1
                    Tab_Shapes(2, 11) = "Objet OLE lié"
                Case 11
                    Tab_Shapes(1, 12) = Tab_Shapes(1, 12) + 1
                    Tab_Shapes(2, 12) = "Image liée"
                Case 12
                    Tab_Shapes(1, 13) = Tab_Shapes(1, 13) + 1
                    Tab_Shapes(2, 13) = "Objet de contrôle OLE"
                Case 13
                    Tab_Shapes(1, 14) = Tab_Shapes(1, 14) + 1
                    Tab_Shapes(2, 14) = "Image"
                Case 14
                    Tab_Shapes(1, 15) = Tab_Shapes(1, 15) + 1
                    Tab_Shapes(2, 15) = "Espace résevé"
                Case 15
                    Tab_Shapes(1, 16) = Tab_Shapes(1, 16) + 1
                    Tab_Shapes(2, 16) = "Effet de texte"
                Case 16
                    Tab_Shapes(1, 17) = Tab_Shapes(1, 17) + 1
                    Tab_Shapes(2, 17) = "Support"
                Case 17
                    Tab_Shapes(1, 18) = Tab_Shapes(1, 18) + 1
                    Tab_Shapes(2, 18) = "Zone de texte"
                Case 18
                    Tab_Shapes(1, 19) = Tab_Shapes(1, 19) + 1
                    Tab_Shapes(2, 19) = "Ancre de script"
                Case 19
                    Tab_Shapes(1, 20) = Tab_Shapes(1, 20) + 1
                    Tab_Shapes(2, 20) = "Tableau"
                Case 20
                    Tab_Shapes(1, 21) = Tab_Shapes(1, 21) + 1
                    Tab_Shapes(2, 21) = "Zone de dessin"
                Case 21
                    Tab_Shapes(1, 22) = Tab_Shapes(1, 22) + 1
                    Tab_Shapes(2, 22) = "Diagramme"
                Case 22
                    Tab_Shapes(1, 23) = Tab_Shapes(1, 23) + 1
                    Tab_Shapes(2, 23) = "Encre"
                Case 23
                    Tab_Shapes(1, 24) = Tab_Shapes(1, 24) + 1
                    Tab_Shapes(2, 24) = "Commentaire manuscrit"
                Case 24
                    Tab_Shapes(1, 25) = Tab_Shapes(1, 25) + 1
                    Tab_Shapes(2, 25) = "Graphique SmartArt"
            End Select
        Next Shp
    Next Wsh
 
    For i = 1 To 25
        If Tab_Shapes(1, i) <> 0 Then
        Mess = Mess & Tab_Shapes(1, i) & " de type " & Tab_Shapes(2, i) & vbCrLf
        End If
    Next
 
    MsgBox Mess, vbInformation, " Listes des shapes"
 
End Sub

02/11/2018, 22h52
SAK78

Bonjour Igloobel,
après exécution de ta proposition, je trouve 122 objet shapes de type forme libre, 1 de type contrôle de formulaire et 1 de type image.
02/11/2018, 23h11
patricktoulon

re

somme toute

en lisant en diagonale je vois une boulette
ici

Code:

Selection.ShapeRange.Fill.ForeColor.RGB = Range(Range("actDeptCode")).Value.Interior.Color

.Value.Interior.Color:calim2::koi:???????

ca serait pas plutot

Code:

Range(Range("actDeptCode").Value).Interior.Color

et puis le parent du range bleu c'est qui ??????????omissions comise dans le code un peu plus haut aussi ;)
02/11/2018, 23h36
SAK78

Merci Patrictoulon de ta réponse.

c'est vraiment le

Code:

ActiveSheet.Shapes(Range("actDept").Value).Select

qui pose problème. Le bug est à cet endroit. C'est comme si les shapes n'étaient pas retrouvées...