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
Bookmarks