Return images based on cell value (100 images and variable cells)

Question

I'm trying to make a TFT (Teamfight Tactics) sheet for me and wanted to make it look better. To do this I wanted to add images of the champions from the game. The image should appear below when I'm entering the name. I've found a way to insert all images into the excel sheet (~100) and also successfully made one dynamic image:

=insertIMG:

=INDEX(PIC!$B$1:$B$55;MATCH(Sheet1!B4;PIC!$A$1:$A$55;0))

I tried to make the Sheet1!B4 part variable but it doens't work for the cell D5. The only solution right now for me would be to make a Name range for every "slot", but this would take a huge amount of time. Is there a way to make excel insert images below just by entering the name?

Answer 1

You can achieve what you want using the Worksheet_Change event.

For demonstration purpose, I am going to take 3 cells B4, C4 and D4

Let's say our images sheet (Let's call it PIC) looks like this.

If you notice, I have inserted a blank shape in the 2nd row. We will use this shape if user presses delete in B4, C4 or D4. We will also use this image if there is no match found.

Now let's prepare our main worksheet. Follow these steps

1. Select cell B2(and not the shape) in the PIC sheet and press CRTL + C.
2. Right click on the cell B5 in the main sheet and click on Paste Special-->Linked Picture as shown below.
3. Repeat for Cell C5 and D5. Your worksheet now looks like this.
4. We are now ready with the basic setup. Open VBE and paste the below code in the worksheet code area and we are done!

Code:

Option Explicit

'More about Worksheet_Change at the below link
'https://stackoverflow.com/questions/13860894/why-ms-excel-crashes-and-closes-during-worksheet-change-sub-procedure/13861640#13861640

Private Sub Worksheet_Change(ByVal Target As Range)
    '~~> Check if multiple cells were changed
    If Target.Cells.CountLarge > 1 Then Exit Sub

    On Error GoTo Whoa

    Application.EnableEvents = False

    If Not Intersect(Target, Range("B4:D4")) Is Nothing Then
        Dim wsPic As Worksheet
        Dim pic As Shape, txtShp As Shape, shp As Shape
        Dim addr As String
        Dim aCell As Range

        '~~> Identify the shape below the changed cell
        For Each shp In ActiveSheet.Shapes
            If shp.TopLeftCell.Address = Target.Offset(1).Address Then
                Set txtShp = shp
                Exit For
            End If
        Next shp

        Set wsPic = ThisWorkbook.Sheets("PIC")

        '~~> Find the text in the PIC sheet
        Set aCell = wsPic.Columns(1).Find(What:=Target.Value2, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        '~~> Identify the shape
        If Not aCell Is Nothing Then
            For Each shp In wsPic.Shapes
                If shp.TopLeftCell.Address = aCell.Offset(, 1).Address Then
                    Set pic = shp
                    addr = aCell.Offset(, 1).Address
                    Exit For
                End If
            Next shp
        End If

        '~~> Add the formula to show the image
        If Not pic Is Nothing And Not txtShp Is Nothing Then
            txtShp.Select '<~~ Required to insert the formula
            Selection.Formula = "=PIC!" & addr
        Else
            txtShp.Select
            Selection.Formula = "=PIC!$B$2"
        End If
        Target.Select '<~~ Remove focus from the shape
    End If

Letscontinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume Letscontinue
End Sub

In Action

Sample File

You may download the sample file from Here

Answer 2

Function insertIMG(ByVal rng As Range)
    Dim rng2 As String
    rng2 = "$D$5" 'Application.Caller.Address  (Now here is a hardcoded adress, the application.caller.address is a reference to the cell that called the function, and should be used when it's running as an UDF.)
    Dim row As Integer
    row = Application.WorksheetFunction.Match(rng, Sheets("PIC").Range("A1:A5"), 0)
    Sheets("PIC").Range("B" & row).Copy
    With Worksheets("Blad1")
       'adapt worksheet name as appropriate
       .Pictures.Paste(Link:=True).Select
    End With
    insertIMG = ""
End Function

If I call this from within a sub whilst I have D5 selected it will insert a linked image. This SUB I used:

Sub test()
    insertIMG(Application.Workbooks("Map1").Worksheets("Blad1").Range("D4"))
    'adapt workbook and worksheet name as appropriate
End Sub

When I run this straight as a formula I get some error.