problème insertion images en fonction d'une valeur
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:
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 |
