VBA Excel - problème balayage d'une liste à taille variable et offset

Signaler
Messages postés
2
Date d'inscription
samedi 8 janvier 2011
Statut
Membre
Dernière intervention
8 janvier 2011
-
Messages postés
2
Date d'inscription
samedi 8 janvier 2011
Statut
Membre
Dernière intervention
8 janvier 2011
-
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 (météo du Tf) 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.
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 ne dépose pas en colonne M et surtout que l'insertion s'effectue à l'infinie...et donc plante mon PC ! Car j'ai inscrit une ligne disant de ne rien faire si la valeur est nulle...



Voici le code en question :

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

1 réponse

Messages postés
2
Date d'inscription
samedi 8 janvier 2011
Statut
Membre
Dernière intervention
8 janvier 2011

UP !!!!!

J'ai besoin d'aide svp !