Discussion :

[narbaits]

Bonjour à toutes & à tous,

Je vous expose mon problème :

J'ai un tableau excel avec en colonne A une liste des personnes ; en colonne H le taux de fréquence (Tf) de ces personnes.

La liste des Tf commence en H3 et peut aller jusqu'à H10 ou H15... une zone indéfinie. J'ai donc sélectionner la plage H3:H65536 comme zone "Tf".

La cellule Q10 est une valeur maxi du Tf au-delà de laquelle je considère comme mauvais les résultats.
La cellule D18 est une l'objectif annuel de ces personnes.

J'insére une image en fonction de la valeur du Tf et là j'ai trouver un code VBA qui marche à merveille car l'image est redimensionnée à la taille de la cellule...bref.
L'insertion de l'image doit ce faire dans la colonne M correspondant à la ligne du Tf analysé.

Par contre je ne comprend pas pourquoi mon code effectue cette boucle à l'infinie, pas dans la colonne M de la ligne et surtout pourquoi il insert une image alors que la valeur des lignes hors tableau sont égales à 0.

Help !!!!



Voici le code en question :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Command_meteo_Click() 
 
Set r = Range("Tf") 
 
For n = Range("H3") To r.Rows.Count 
 
'paramètre pour insertion image en fonction de la valeur 
Dim Fichier As String 
Dim objImg As Object 
Dim Emplacement As Range 
 
 
 
If r.Cells(n, 8) = 0 Then 
End If 
 
 
If r.Cells(n, 8) > Range("Q10") Then 
r.Cells(n, 8).Offset(0, 5).Activate 
 
Fichier = "C:\Documents and Settings\a.narbaits-jaureguy\Mes documents\Mes images\image3.gif" 
Set objImg = ActiveSheet.Pictures.Insert(Fichier) 
Set Emplacement = ActiveCell 
Set objImg = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count) 
 
With objImg.ShapeRange 
.LockAspectRatio = msoFalse 
.Left = Emplacement.Left 
.Top = Emplacement.Top 
.Height = Emplacement.Height 
.Width = Emplacement.Width 
End With 
 
End If 
 
 
 
 
If Range("D18") < r.Cells(n, 8) < Range("Q10") Then 
r.Cells(n, 8).Offset(0, 5).Activate 
 
Fichier = "C:\Documents and Settings\a.narbaits-jaureguy\Mes documents\Mes images\image2.gif" 
Set objImg = ActiveSheet.Pictures.Insert(Fichier) 
Set Emplacement = ActiveCell 
Set objImg = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count) 
 
With objImg.ShapeRange 
.LockAspectRatio = msoFalse 
.Left = Emplacement.Left 
.Top = Emplacement.Top 
.Height = Emplacement.Height 
.Width = Emplacement.Width 
End With 
 
End If 
 
 
 
 
If Range("D18") > r.Cells(n, 8) Then 
r.Cells(n, 8).Offset(0, 5).Activate 
 
Fichier = "C:\Documents and Settings\a.narbaits-jaureguy\Mes documents\Mes images\image1.gif" 
Set objImg = ActiveSheet.Pictures.Insert(Fichier) 
Set Emplacement = ActiveCell 
Set objImg = ActiveSheet.DrawingObjects(ActiveSheet.Shapes.Count) 
 
With objImg.ShapeRange 
.LockAspectRatio = msoFalse 
.Left = Emplacement.Left 
.Top = Emplacement.Top 
.Height = Emplacement.Height 
.Width = Emplacement.Width 
End With 
 
End If 
 
 
 
 
Next n 
End Sub

[mercatog]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Private Sub Command_meteo_Click()
Dim Dossier As String, Fichier As String
Dim LastLig As Long, i As Long
Dim Emplacement As Range
Dim objImg As Object
 
Application.ScreenUpdating = False
Dossier = "C:\Documents and Settings\a.narbaits-jaureguy\Mes documents\Mes images\"
'adapte le nom de ta feuille
With Sheets("Feuil6")
   LastLig = .Cells(.Rows.Count, "H").End(xlUp).Row
   For i = 3 To LastLig
      If .Range("H" & i).Value > .Range("Q10").Value Then
         Fichier = Dossier & "image3.gif"
      Else
         If .Range("H" & i).Value > .Range("D18").Value Then
            Fichier = Dossier & "image2.gif"
         Else
            Fichier = Dossier & "image1.gif"
         End If
      End If
 
      Set objImg = .Pictures.Insert(Fichier)
      Set Emplacement = .Range("M" & i)
      With objImg.ShapeRange
         .LockAspectRatio = msoFalse
         .Left = Emplacement.Left
         .Top = Emplacement.Top
         .Height = Emplacement.Height
         .Width = Emplacement.Width
      End With
      Set objImg = Nothing
      Set Emplacement = Nothing
   Next i
End With
End Sub

[narbaits]

Merci beaucoup pour ce coup de pouce magique !!

Par contre dans le but de bien comprendre mon erreur, je souhaiterais savoir qu'est ce qui faisait que mon code était erroné ?
J'ai essayé d'appliquer des lignes de commandes simples... mais ton écriture est bien plus élaborée.

Peux tu m'expliquer ??

En tout cas merci à toi pour ton aide rapide et efficasse !

[mercatog]

1.

J'ai donc sélectionner la plage H3:H65536 comme zone "Tf"

Pourquoi travailler avec toute la colonne qui comporte quand même trop de cellules
2.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
If r.Cells(n, 8) = 0 Then 
End If

Ces lignes qu'est ce qu'ils font?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If Range("D18") < r.Cells(n, 8) < Range("Q10") Then

Je n'ai pas testé mais quand même ça reste bizarre pour du vba
3. Tes 3 tests ne sont pas imbriqués, ils sont malgré tout exécutés tous les 3 succéssivement
4. Enfin, c'était une simple simplification, dans chaque test issu de la boucle, seul le nom de l'image change.

[narbaits]

Ok je comprend mieux maintenant pourquoi cela ne fonctionnait pas.

J'aurai une dernière question...
Comment pourrais-je supprimer ces images mise en colonne M sans supprimer la légende mise sur le côté du tableau (avec donc les mêmes images et la signification de chacune d'elles pour l'utilisateur).

Car la plus part des codes suppriment l'ensemble des images de la feuille.
Or je souhaite conserver 3 d'entre-elle dans la légende.
Je les ai insérée dans une "image box" verrouillée mais sans succès...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
For Each img In Sheets("Grand Sud ouest").Shapes
    img.Delete
Next

Merci pour toutes tes indications.

Cordialement.

[mercatog]

Ces 3 images, qu'est qu'elles ont en commun? si c'est le nom, exemple TOTO1, TOTO2 et TOTO3

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
For Each img In Sheets("Grand Sud ouest").Shapes
if left(img.name,4)<>"TOTO" then img.Delete
Next

[narbaits]

J'ai bien saisie le concept de cette commande

Mais par contre lorsque je l'execute, il supprime mes textbox & le bouton de commande qui lance la macro

Pourtant j'ai spécifié que je veux supprimer uniquement les images avec le terme "Image ".

Je ne vois pas où l'instruction n'est pas "logique" ?!
J'ai renomé les images de la légende avec ADF1, ADF2... Donc je ne comprend pas pq ces images sont également supprimées.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Private Sub CommandButton2_Click()
 
For Each img In Sheets("Grand Sud ouest").Shapes
If Left(img.Name, 4) <> "ADF" Then img.Delete
Next
 
End Sub

[mercatog]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Dim img As Shape
 
For Each img In Sheets("Feuil1").Shapes
   If img.Type = 13 And Left(img.Name, 3) <> "ADF" Then img.Delete
Next img

il faut spécifier quel type de shape tu veux supprimer
supprimer seulement les images (type 13) qui ne commencent pas par ADF

[narbaits]

Merci énormément Mercatog

C'est parfait et cela fonctionne au poil !!!!

Dernière question... que signifie images (type 13) ?! Car j'ai beau essayer de lire l'aide de VBA, mais c'est pas clair du tout

Merci pour ton aide très avisée !

[mercatog]

Recherche dans le help MsoShapeType

MsoShapeType, énumération
Spécifie le type d'une forme ou d'un ensemble de formes.
Nom Valeur Description
msoAutoShape 1 Forme automatique
msoCallout 2 Légende
msoCanvas 20 Zone de dessin
msoChart 3 Graphique
msoComment 4 Commentaire
msoDiagram 21 Diagramme
msoEmbeddedOLEObject 7 Objet OLE incorporé
msoFormControl 8 Contrôle de formulaire
msoFreeform 5 Forme libre
msoGroup 6 Groupe
msoIgxGraphic 24 Graphique SmartArt
msoInk 22 Encre
msoInkComment 23 Commentaire manuscrit
msoLine 9 Trait
msoLinkedOLEObject 10 Objet OLE lié
msoLinkedPicture 11 Image liée
msoMedia 16 Support
msoOLEControlObject 12 Objet de contrôle OLE
msoPicture 13 Image
msoPlaceholder 14 Espace réservé
msoScriptAnchor 18 Ancre de script
msoShapeTypeMixed -2 Type de forme mixte
msoTable 19 Tableau
msoTextBox 17 Zone de texte
msoTextEffect 15 Effet de texte