Calculate range instead of single cell

[robseitz74]

I have this code that works great on a single cell but I want to apply it to a range of cells and can't seem to get it to work. Any assistance with this would be wonderful as I am creating something for work and this is the last step I need to overcome to complete the project! The code I'm starting with is:

Private Sub Worksheet_Calculate()
Dim oPic As Picture
Me.Pictures.Visible = False
With Range("J5")
For Each oPic In Me.Pictures
If oPic.Name = .Text Then
oPic.Visible = True
oPic.Top = .Top
oPic.Left = .Left
Exit For
End If
Next oPic
End With
End Sub

Thank you for any and all guidance as I am still new to excel and learning my way around. The issue is line 4 (With Range) if I change J5 to the range of cells I'm looking to use it on it no longer returns the pic for any cell.

 

[robseitz74]

@GWteB I'm not sure what I've done wrong but following your updated info and guidance I can't get any of the pics to display.

 

[GWteB]

Indeed, the code did not work quite well ; sometimes yes, sometimes no, sometimes Excel crashed.
The enclosed code did not cause any problems for me anymore. The only conditions that exist are that the pictures are on the same worksheet and that the numbers must be entered manually. No pictures are swapped by selecting a cell with a number within column F:F and copying it by dragging.

This goes in the worksheet module:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim r   As Range
    If Target.CountLarge > 1 Then Exit Sub
    Set r = Application.Intersect(Target, Me.Range("F5:F104"))
    If Not r Is Nothing Then
        ' the value of any cell within range F5:F104 has been changed, so ...
        ' invoke desired action
        Call GetPicture(Target)
    End If
    Set r = Nothing
End Sub

This goes in a standard module:

Option Explicit

Private bPictureBusy    As Boolean

Public Function PictureExists(ByRef argSht As Worksheet, ByRef argPict As String) As Boolean
    Dim oPict
    For Each oPict In argSht.Pictures
        If StrComp(oPict.Name, argPict, vbTextCompare) = 0 Then
            PictureExists = True
            Exit For
        End If
    Next
End Function

Public Sub GetPicture(ByVal argTarget As Range)

    Dim raTmp       As Range
    Dim raPict      As Range
    Dim oPict       As Picture
    
    If Not bPictureBusy Then
    
        ' prevent run-time conflicts
        bPictureBusy = True
        
        With Application
            .EnableEvents = False
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
        End With
        
        ' backup so it can be restored
        Set raTmp = ActiveCell
        
        ' VLOOKUP is on same row, 4 colums ahead, ie Columns("J")
        ' and is expected to contain the picture name
        Set raPict = argTarget.Offset(0, 4)
    
        ' delete previous picture (if there is any...)
        For Each oPict In argTarget.Parent.Pictures
            If oPict.TopLeftCell.Address = raPict.Address Then
                oPict.Delete
                Exit For
            End If
        Next
    
        ' obtain picture name and perform copy / paste
        ' some precautions are taken to prevent Run-time errors
        With argTarget
            If Not IsEmpty(raPict) And Not IsError(raPict) And Not IsNumeric(raPict) Then
                If PictureExists(raPict.Parent, raPict.Value) Then
                    .Parent.Pictures(raPict.Value).Copy
                    raPict.Select
                    On Error Resume Next
                    .Parent.Paste
                End If
            End If
        End With
        
        'restore
        raTmp.Select
        
        With Application
            .EnableEvents = True
            .Calculation = xlCalculationAutomatic
            .ScreenUpdating = True
        End With
        
        ' done
        bPictureBusy = False
        
        Set oPict = Nothing
        Set raPict = Nothing
        Set raTmp = Nothing
    End If
End Sub

 

[robseitz74]

This works exactly as I need it to! Only thing that could be better would be if I could copy and paste numbers in but that's very minor. I have so much to learn but this excites me and I appreciate your assistance with this!

 

[GWteB]

Glad to help and thanks for letting me know.

Only thing that could be better would be if I could copy and paste numbers in but that's very minor.

You can however just one cell at a time. The code would be much more involved to make such a possibility available.