[VBA] - Looping Through Image Controls Based on Cell Contents

[DC20]

I have an Excel Spreadsheet which reports upon weekly performance. One portion of the worksheet looks at week over week increases/decreases. I've placed a number of image controls (15 in Total) next to cells which calculate week over week change. The image controls simply display an image depending on whether the value of the adjacent cell is positive or negative.

So, here is where I'm going with it:

Dim loopme(15, 1) As Variant  loopme(0, 0) = "J26" loopme(0, 1) = "Image1" loopme(1, 0) = "J27" loopme(1, 1) = "Image2" loopme(2, 0) = "J33" loopme(2, 1) = "Image3"   For x = 0 To 15  cell = loopme(x, 0) img = loopme(x, 1)   If Range(cell).Value > 0 And IsNumeric(Range(cell).Value Then  img.Picture = LoadPicture("C:\path\to\up_arrow.gif")  ElseIf Range(cell).Value < 0 And IsNumeric(Range(cell).Value Then  img.Picture = LoadPicture("C:\path\to\down_arrow.gif")  Else  img.Picture = LoadPicture("")  End If    Next x</pre>

As you can see, this is pretty simple. What I'd like to do is find a way to loop through all 15 controls and avoid having 15 IF statements run on the Worksheet_Change() event. The cells containing the week over week values are all in the same column, but not continuous. Involved cells are: ("J26", "J27", "J33", "J34", "J35", "J36", "J37", "J38", "J39", "J40", "J42", "J43", "J44", "J45", "J46")

How does one assign different types to the same array? The above, of course, spits out a type error when using the 'img' variable.

Anyone have any insight into how best to accomplish this?

Thanks in advance.

 

[Gary McMaster]

If I'm understanding you, maybe you could use the "TopLeftCell" (or "BottomRightCell") property of the image combined with "Offset" to accomplish this. Something like the sample below:

Gary

Public Sub Test()

Dim oImage As Shape
Dim oRange As Range

Set oRange = ActiveSheet.Range("J26:J33")

For Each oImage In ActiveSheet.Shapes
    If Not Application.Intersect(oImage.TopLeftCell, oRange) Is Nothing Then
        If oImage.Type = msoLinkedPicture Or oImage.Type = msoPicture Then
            If oImage.TopLeftCell.Offset(0, 1).Value > 0 And IsNumeric(oImage.TopLeftCell.Offset(0, 1).Value) Then
                oImage.Picture = LoadPicture("C:\path\to\up_arrow.gif")
            Else
                oImage.Picture = LoadPicture("C:\path\to\down_arrow.gif")
            End If
        End If
    End If
Next oImage

End Sub

Depending on what kind of images you are using you may have to use this instead:

For Each oImage In ActiveSheet.OLEObjects

    Debug.Print oImage.TopLeftCell.Address

Next

 

[DC20]

You are awesome. It is working as intended with the following code:

Dim oImage As OLEObject

For Each oImage In ActiveSheet.OLEObjects

    Debug.Print oImage.TopLeftCell.Offset(0, 1).Address

            If oImage.TopLeftCell.Offset(0, 1).Value > 0 And IsNumeric(oImage.TopLeftCell.Offset(0, 1).Value) Then
                oImage.Object.Picture = LoadPicture("C:\path\to\up_arrow.gif")
            ElseIf oImage.TopLeftCell.Offset(0, 1).Value < 0 And IsNumeric(oImage.TopLeftCell.Offset(0, 1).Value) Then
                oImage.Object.Picture = LoadPicture("C:\path\to\down_arrow.gif")
                Else
                oImage.Object.Picture = LoadPicture("")
            End If

Next oImage

Now I just need to figure out how to embed the image, so I do not have to load it locally.

Thanks again.

 

[Gary McMaster]

Try inserting the image as a shape. I may not have the sample code exactly right but it should be pretty close.

Gary

Public Sub Test()

Dim oShape As Shape
Dim oSheet As Worksheet 

Set oSheet = ActiveSheet 'Enable intellisense
Set oShape = oSheet.Shapes.AddPicture(Filename:="Path & Filename string here", Left:=Range("B2").Left, Top:=Range("B2").Top, Width:=50, Height:=50)

oShape.TopLeftCell = oSheet.Range("J12")
'oShape. lots of other properties

End Sub

 

[Gary McMaster]

On second thought, it might be easier to just use the built in "Autoshapes". You could superimpose the up and down arrow shapes and turn visiblity on and off or just use 1 arrow shape and adjust the rotation.

Gary

Please try in a new workbook, standard module.

Public Sub Test()

Dim oShape As Shape
Dim oSheet As Worksheet
Dim oOrigin As Range
Dim siLeft As Single
Dim siTop As Single
Dim siWidth As Single
Dim siHeight As Single

Set oSheet = ActiveSheet

siWidth = 20
siHeight = 20

Set oOrigin = oSheet.Range("D10")

siLeft = oOrigin.Left
siTop = oOrigin.Top

For Each oShape In oSheet.Shapes 'Delete all existing shapes (duplicate names not allowed)
    oShape.Delete
Next oShape

'Could also use a single shape and change ".Rotation" and fill color for up/down
'May require recomputing .Top & .Left if displacement occurs
Set oShape = oSheet.Shapes.AddShape(msoShapeUpArrow, siLeft, siTop, siWidth, siHeight)

oShape.Name = "Up" & oOrigin.Address 'Build unique names for easy identification
oShape.Fill.ForeColor.RGB = RGB(0, 255, 0)

oShape.Visible = msoTrue

Set oShape = oSheet.Shapes.AddShape(msoShapeDownArrow, siLeft, siTop, siWidth, siHeight)

oShape.Name = "Down" & oOrigin.Address
oShape.Fill.ForeColor.RGB = RGB(255, 0, 0)

oShape.Visible = msoFalse

Dim iAnswer As Integer

DoItAgain:

DoEvents

'Use ".Offset" and data in adjacent cell to toggle up/down visibility instead of following.
iAnswer = MsgBox("Click OK to toggle up down arrow visibility, Cancel to exit", vbOKCancel, "Test")

If iAnswer = vbOK Then
    'Shape name = "Up" or "Down" concatenated with containing cell address
    oSheet.Shapes("Up" & oOrigin.Address).Visible = Not oSheet.Shapes("Up" & oOrigin.Address).Visible
    oSheet.Shapes("Down" & oOrigin.Address).Visible = Not oSheet.Shapes("Down" & oOrigin.Address).Visible
    GoTo DoItAgain
End If

End Sub

 

[DC20]

I will give this a try if I have a moment today. I appreciate your help.

Is there any particular advantage to loading the image as a shape rather than within the MSOObject?

 

[Gary McMaster]

Now I just need to figure out how to embed the image

It will be embedded. If you use the "Autoshape" arrow you won't have to load or embed anything. They are built in.

Gary

 

[DC20]

Very neat. I have been playing around with the following code:

Private Sub Worksheet_Change(ByVal test As Range)

Dim oShape As Shape
Dim oSheet As Worksheet
Dim oOrigin As Range
Dim siLeft As Single
Dim siTop As Single
Dim siWidth As Single
Dim siHeight As Single

Set oSheet = ActiveSheet

'Unprotect Shapes for shape deletion
oSheet.Protect DrawingObjects:=False, Contents:=False, Scenarios:=False, userinterfaceonly:=False

siWidth = 8
siHeight = 8

'Cells with W/W values
Set oOrigin = oSheet.Range("A1:A25", "B1:B25")

'Delete Existing Shapes
For Each oShape In oSheet.Shapes

    If Not Application.Intersect(oShape.TopLeftCell, oOrigin) Is Nothing Then
         oShape.Delete
    End If
  
Next oShape

For Each oLoc In oOrigin

siLeft = oLoc.Left
siTop = oLoc.Top

'Add Shape Based on W/W Values
If oLoc.Value > 0 And IsNumeric(oLoc.Value) Then
Set oShape = oSheet.Shapes.AddShape(msoShapeUpArrow, siLeft, siTop, siWidth, siHeight)

oShape.Name = "Up" & oLoc.Address 'Name the shapes to avoid duplication
oShape.Fill.ForeColor.RGB = RGB(50, 205, 50)
oShape.Line.Visible = msoFalse
oShape.Visible = msoTrue
oShape.Locked = True

ElseIf oLoc.Value < 0 And IsNumeric(oLoc.Value) Then
Set oShape = oSheet.Shapes.AddShape(msoShapeDownArrow, siLeft, siTop, siWidth, siHeight)

oShape.Name = "Down" & oLoc.Address
oShape.Fill.ForeColor.RGB = RGB(255, 0, 0)
oShape.Line.Visible = msoFalse
oShape.Visible = msoTrue
oShape.Locked = True

End If

Next oLoc

'Protect Shapes
oSheet.Protect DrawingObjects:=True, Contents:=False, Scenarios:=False, userinterfaceonly:=False

End Sub

Now I only need to add additional conditions to determine color. For example, if cost goes down, the arrow should point down but also be green. I will mull this over. I think I will simply define two different ranges and add the arrows depending on the range.

Thanks again for your input Gary.