conditionally insert image

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Hello,
I'm working on a rating system that will provide feed back based on one of
five images. The range of values is between 0 and 1.

0 - .2
..21 - .4
..41 - .6
..61 - 8
..81 - 1

I would like to be able to select a column of numbers and have a macro that
selects from one of five images to place in that cell.

Thanks to people on this discussion board, I've already got the code that
will insert an image based on an cell value (if A1 = 1, then insert an image)
as well as centering and sizing the image to the cell, but....I haven't yet
figured out (nor seen on the discussion board) how to assign a picture per
cell over a range of cells, based on the values in the cells.

Any help you can provide will be most appreciated.
Many thanks in advance,
MJohn
 
Obviously it would be to use the same code on the other cells.
I would like to be able to select a column of numbers and have a macro that
selects from one of five images to place in that cell.
Click to expand...

What does that mean - select a column, but put a value in a cell? - what
cell - a column has 65536 cells. Be specific about what you are doing.

Post your code that you have described and exactly what range of cells you
want to work with and when you want the action to happen and how the action
will happen and perhaps someone can give you some advice.

How would be something like the cell changes based on a formula, the cell
changes because someone edits it, the cell changes because a macro changes
it.
 
Okay, sorry for the ambiguity.
Here's the code:

Sub InsertGIF()
Dim myCell As Range
Set myCell = Selection

On Error Resume Next
If ActiveCell.Value <= 0.2 Then
ActiveSheet.Shapes("A1 Picture").Delete
ActiveCell.Select
ActiveSheet.Pictures.Insert("C:\Ratings\05Worst.gif").Select
Selection.Name = "A1 Picture"
With ActiveSheet.Shapes("A1 Picture")
.Top = ActiveCell.Top + (ActiveCell.Height - .Height) / 2
.Left = ActiveCell.Left + (ActiveCell.Width - .Width) / 2
End With
Else
ActiveSheet.Shapes("A1 Picture").Delete
End If

myCell.Select
End Sub

And to clear up the 'column' matter. For cells with the following values:

A1 = .05
B1 = 0.1
C1 = 0.15
D1 = 0.2
E1 = 0.25
F1 = 0.3
G1 = 0.35

The above code correctly places a "03Worst.gif" image in the first four
cells, if I go through and individually select them.....what I would like, is
to select the whole range of cells and run a macro that will assign other
pictures to the other values, up to 1, based on the range scheme below.

Hope this clears things up. Thanks for the quick response.

MJohn
 
If the selection is anywhere in the Range A1:g1, It processes the entire
range A1:G1

Sub InsertGIF()
Dim myCell As Range, cell As Range
Dim shp As Shape, rng1 As Range
Dim shp1 As Picture
Dim s As String
Set rng1 = Range("A1:G1")
Set myCell = Selection

If Not Intersect(myCell, rng1) Is Nothing Then
For Each cell In Range("A1:G1")
If cell.Value <= 0.2 Then
On Error Resume Next
s = cell.Address(0, 0) & " Picture"
Set shp = ActiveSheet.Shapes(s)
shp.Delete
On Error GoTo 0
'"C:\Ratings\05Worst.gif"
Set shp1 = ActiveSheet.Pictures.Insert("C:\woodland.gif")
shp1.Name = s
With shp1
.Top = cell.Top + (cell.Height - .Height) / 2
.Left = cell.Left + (cell.Width - .Width) / 2
End With
Else
On Error Resume Next
s = cell.Address(0, 0) & " Picture"
Set shp = ActiveSheet.Shapes(s)
shp.Delete
On Error GoTo 0
End If
Next
End If
End Sub
 
EXCELLENT. Woo-hoo. That inserted the "05Worst.gif" across rows and
columns. That's beautiful.

If I can get the .21<x<=.4 (and subsequent parts) coded, I'll be set. I'm
guessing this will be something like

Else If cell.Value > 0.2 And <=0.4 Then...

Am I on the right track?

Again, many thanks.

MJohn
 
Oh, and here's how I modified the code you gave me to make it a more generic
as to the row/columns:

Sub InsertGIF()
Dim myCell As Range, cell As Range
Dim shp As Shape, rng1 As Range
Dim shp1 As Picture
Dim s As String
Set rng1 = Selection
Set myCell = Selection

If Not Intersect(myCell, rng1) Is Nothing Then
For Each cell In rng1
If cell.Value <= 0.2 Then
On Error Resume Next
s = cell.Address(0, 0) & " Picture"
Set shp = ActiveSheet.Shapes(s)
shp.Delete
On Error GoTo 0
Set shp1 = ActiveSheet.Pictures.Insert("C:\Documents and
Settings\michael.j.foley\Desktop\Ratings\05Worst.GIF")
shp1.Name = s
With shp1
.Top = cell.Top + (cell.Height - .Height) / 2
.Left = cell.Left + (cell.Width - .Width) / 2
End With
Else
On Error Resume Next
s = cell.Address(0, 0) & " Picture"
Set shp = ActiveSheet.Shapes(s)
shp.Delete
On Error GoTo 0
End If
Next
End If
End Sub
 
I would do it like this if you have 5 different pictures you want to
display:

Sub InsertGIF()
Dim myCell As Range, cell As Range
Dim shp As Shape, rng1 As Range
Dim shp1 As Picture
Dim s As String, sPath = String
Dim s2 as String
Set rng1 = Selection
Set myCell = Selection

sPath = "C:\Documents and Settings\" & _
"michael.j.foley\Desktop\Ratings\"
If Not Intersect(myCell, rng1) Is Nothing Then
For Each cell In rng1
If cell.Value >= 0 and cellValue <= 1.0 then
If cell.Value <= 0.2 Then
s2 = "05Worst.GIF"
elseif cell.Value <= 0.4 then
s2 = "04Worst.Gif"
elseif cell.Value <= 0.6 then
s2 = "03Worst.Gif"
elseif cell.Value <= 0.8 then
s2 = "02Worst.Gif"
elseif cell.Value <= 1.0 then
s2 = "01Worst.Gif"
end if

On Error Resume Next
s = cell.Address(0, 0) & " Picture"
Set shp = ActiveSheet.Shapes(s)
shp.Delete
On Error GoTo 0
Set shp1 = ActiveSheet.Pictures.Insert(sPath & s2)
shp1.Name = s
With shp1
.Top = cell.Top + (cell.Height - .Height) / 2
.Left = cell.Left + (cell.Width - .Width) / 2
End With
Else
On Error Resume Next
s = cell.Address(0, 0) & " Picture"
Set shp = ActiveSheet.Shapes(s)
shp.Delete
On Error GoTo 0
End If
Next
End If
End Sub
 
Mr. Ogilvy,
Wow. That works (with only one modification: deleted the "shp.Delete" so
that the entire selected field gets rated) EXACTLY as I hoped it would.

Thank you very much. You're an all star.

MJohn
 
Back
Top