根据单元格值返回图像（100 个图像和可变单元格）

Question

我正在尝试为我制作一个 TFT（Teamfight Tactics）表，并希望让它看起来更好。为此，我想添加游戏中冠军的图像。当我输入名称时，图像应该出现在下面。我找到了一种将所有图像插入到 excel 表（~100）中的方法，并且还成功地制作了一张动态图像：

=插入IMG：

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

我试图使 Sheet1!B4 部分可变，但它不适用于单元格 D5。现在对我来说唯一的解决方案是为每个“插槽”创建一个名称范围，但这将花费大量时间。有没有办法只输入名称就可以让excel在下面插入图片？

Answer 1

你你可以使用Worksheet_Change事件来实现你想要的。

出于演示目的，我将取 3 个单元格 B4、C4 和 D4

假设我们的图片表（我们称之为PIC）看起来像这样。

如果您注意到，我在第二行插入了一个空白形状。如果用户在B4、C4 或D4 中按下删除，我们将使用此形状。如果找不到匹配项，我们也会使用此图像。

现在让我们准备我们的主要工作表。请按照以下步骤操作

1. 在PIC 工作表中选择单元格B2（而不是形状），然后按CRTL + C。
2. 右键单击主工作表中的单元格B5，然后单击Paste Special-->Linked Picture，如下图所示。
3. 重复单元格C5 和D5。您的工作表现在看起来像这样。
4. 我们现在已准备好进行基本设置。打开VBE，把下面的代码粘贴到工作表代码区就大功告成了！

代码：

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

行动中

示例文件

您可以从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

如果我在选择 D5 的同时从一个子中调用它，它将插入一个链接图像。我使用的这个 SUB：

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

当我直接将其作为公式运行时，我会遇到一些错误。