Forskellige billeder i et excel ark alt efter værdi i celle

Indsæt koden i arkets kodemodul
Skifter når tal i celle F2 ændres, skift F2 om nødvendig
Bilede indsætte i en kommetar i celle F3

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("F2")) Is Nothing Then Exit Sub
On Error Resume Next
Selection.AddComment
Selection.Comment.Visible = True
Selection.Comment.Shape.Select True
If [F2] < 30 Then
Selection.ShapeRange.Fill.UserPicture "C:\Users\pm\Pictures\billede1.jpg"
End If
If [F2] >= 30 And [F2] < 50 Then
Selection.ShapeRange.Fill.UserPicture "C:\Users\pm\Pictures\billede2.jpg"
End If
If [F2] >= 50 And [F2] < 70 Then
Selection.ShapeRange.Fill.UserPicture "C:\Users\pm\Pictures\billede3.jpg"
End If
If [F2] >= 70 And [F2] < 90 Then
Selection.ShapeRange.Fill.UserPicture "C:\Users\pm\Pictures\billede4.jpg"
End If
If [F2] >= 90 And [F2] < 100 Then
Selection.ShapeRange.Fill.UserPicture "C:\Users\pm\Pictures\billede5.jpg"
End If
[F2].Select
End Sub

Super det virker bare perfekt. Send et svar.

velbekom

Øv, har lige konstateret at kommentarene ikke kommer med i det html-output som jeg generere via en makro. Benytte html-outputtet til et website og ville gerne have billederne vist der.

så laver vi bare en anden løsning
skal lige hjem først

Prøv om denne virker, har kun med 3 billeder her, så udvid selv
Du skal muligvis have dine billeder oploaded har ikke testet.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("F2")) Is Nothing Then Exit Sub
On Error Resume Next
ActiveSheet.Pictures.Delete
If [F2] < 30 Then
ActiveSheet.Pictures.Insert ("C:\Users\pm\Pictures\Billede1.jpg")
End If
If [F2] >= 30 And [F2] < 50 Then
ActiveSheet.Pictures.Insert ("C:\Users\pm\Pictures\Billede2.jpg")
End If
If [F2] >= 50 And [F2] < 70 Then
ActiveSheet.Pictures.Insert ("C:\Users\pm\Pictures\Billede3.jpg")
End If

[F2].Select
End Sub

Det virker perfekt. Takker for hjælpen!