Adding Pictures From Drop Down List

[TDeRanger]

Hi All,

I'm a beginner to VBA coding, I copy a code from excel forum to add pictures from a drop down list & it works well but I need to add an additional drop list box & picture to a different area on the spread sheet. I would appreciate any help someone could have on this matters - please see code below:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim vCells As Variant

    On Error GoTo leave
    If Target.Column > 1 Then GoTo leave
    
    'list of addresses for cells with user selection lists
    'NOTE: the $ are necessary!
    vCells = Array("$A$92", "$A$94", "$A$96", "$A$98")
    
    'did user change one of the cells we are watching?
    For n = 0 To UBound(vCells)
        If Target.Address = vCells(n) Then
            'yes ... call the routine that shows picture
            Call showPic(Target)
            Exit For
        End If
    Next n

leave:
End Sub

Private Sub showPic(vCell As Range)
Dim oPic As Shape, oPic2 As Shape
Dim ws As Worksheet
Dim searchRng As Range
Dim searchFor As String
Dim matchRow As Long
Dim picName As String

    Application.ScreenUpdating = False

    'if there is a picture related to this cell, delete it
    On Error Resume Next
    Set oPic = Me.Shapes("Pic" & vCell.Row)
    If Err Or oPic Is Nothing Then
        Err.Clear
    Else
        oPic.Delete
    End If

    On Error GoTo leave
    'read user's selection from list
    searchFor = vCell.Value
    'define worksheet containing list, picture names, and pictures
    Set ws = ThisWorkbook.Worksheets("Options")
    'search column A (column 1) for match to user's selection
    Set searchRng = ws.Columns(1)
    matchRow = 0
    On Error Resume Next
    matchRow = WorksheetFunction.Match(searchFor, searchRng, 0)
    If Err Or matchRow = 0 Then
        Err.Clear
        GoTo leave 'no match, exit
    End If
    
    On Error GoTo leave
    'if we got here, we have found a match for the user's selection
    'find name of picture we are looking for
    picName = ws.Range("B" & matchRow)
    
    For Each oPic In ws.Shapes
        If oPic.Name = picName Then
            oPic.Copy
            Me.Paste
            Set oPic2 = Me.Shapes(Selection.Name)
            oPic2.Name = "Pic" & vCell.Row
            oPic2.Top = vCell.Top
            oPic2.Left = Me.Cells(vCell.Row, 10).Left
            Exit For
        End If
    Next oPic

leave:
    Application.ScreenUpdating = True
End Sub

[TDeRanger]

Two days straight trying to solve my problem, I hate to bother someone else with it but please I
need some help!!

Please see attach file with call out boxes explaining what I'm trying to do - any help would be
deeply appreciated

[jaslake]

Hi TDeRanger

I'm only guessing what you want on Sheet sGames...try the Code in the attached...

[TDeRanger]

Excellent John!!
My problem final solve - many thanks

[jaslake]

You're welcome...glad I could help. Thanks for the Rep.