Excel动态引用图片或照片的三种方法

一、将公式定义成名称进行引用

1、设计一个表格“名单”，保存各项信息，包括照片，如下：

2、切换到公式选项卡，点击名称管理器，如下：

3、新建一个名称“照片”，在“照片”的引用位置输入公式如下：

=INDEX(名单!$L$2:$L$4,MATCH(员工查询表!$B$4,名单!$A$2:$A$4,0))

或者

=OFFSET(名单!$A$1,MATCH(员工查询表!$B$4,名单!$A$2:$A$4,0),11)

说明：不能使用vlookup公式，这里必须使用绝对引用$符号，不然定义的名称的引用位置会变化。若图片需要根据单元格中填写的行号变动，可以在MATCH第一个参数中使用INDIRECT或OFFSET公式，如：=INDEX(名单!$L$2:$L$4,MATCH(INDIRECT("名单!$A$"&名单!$J$6),名单!$A$2:$A$4,0))。

4、复制一张图片到Excel的单元格中，选中该图片，将编辑栏的公式编辑为“=照片”，这样，只要修改B4单元格中数据，就会显示相应照片，如下：

说明：此方法引用的照片，只能根据“员工查询表!$B$4”中的内容进行改变，其他所有引用此名称的照片都是如此。

5、图片的裁剪、填充、线条颜色等属性可以设置图片，如下：

二、使用VBA实现上面图片名称的公式添加

Sub Excel中添加图片引用的名称()

'原表有有编号和编号所在行的图片，此代码实现新表根据原表编号动态显示图片

'新表每行插入空白图片，第二次为图片设置图片引用名称

' "=INDEX(名单!R2C12:R4C12,MATCH(名单!R6C11,名单!R2C1:R4C1,0))"

    On Error Resume Next

    Dim picName As String

    picName = "图片"    '公式名称

    Dim strPicRng As String, strPicId As String, strPicIdRng As String

    strPicIdRng = "名单!R2C1:R4C1"    '原图片根据编号变化，编号所在列

    strPicRng = "名单!R2C12:R4C12"    '原图片所在列

    strPicId = "Sheet3!R"    '新表中的编号所在单元格

    Dim i As Integer

    Dim startRow As Integer, endRow As Integer

    Dim oldPic As Shape

    Dim newPicColNum As Integer, newPicIdCol As Integer

    newPicIdCol = 1    '新图片编号所在列号

    newPicColNum = 2    '新图片所在列号

    startRow = 2    '新图片开始行号

    endRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row    '新表中图片结束行号

    For i = startRow To endRow    '添加公式名称，在新的列中添加图片，并将图片的表达式设置为名称引用

        '定义图片名称

        ActiveWorkbook.Names.Add Name:=picName & i, RefersToR1C1:="=INDEX(" & _

                                                                  strPicRng & ",MATCH(" & strPicId & i & "C" & newPicIdCol & "," & strPicIdRng & ",0))"

        Set oldPic = getCellShape(ActiveSheet.Cells(i, newPicColNum))    '获取单元格区域照片

        If oldPic Is Nothing Then    '单元格区域无照片

            '添加新图片

            ActiveSheet.Cells(i, newPicColNum).CopyPicture

            ActiveSheet.Cells(i, newPicColNum).Select

            ActiveSheet.Paste

            Selection.ShapeRange.Name = "pic" & i

            '            ActiveSheet.Shapes.Range(Array("pic" & i)).Select

            Selection.Formula = "=" & picName & i    '图片名称对应公式必须有图片才行

        Else    '有照片就设置表达式为引用名称

            oldPic.Name = "pic" & i

            oldPic.Select

            Selection.Formula = "=" & picName & i    '图片名称对应公式必须有图片才行

        End If

    Next

End Sub

Function getCellShape(cellRng As Range) As Shape

'获取当前Sheet表格cellRng单元格区域上的图片

    Dim picShape As Shape

    For Each picShape In ActiveSheet.Shapes

        If picShape.Type = msoPicture Then

            If Not Application.Intersect(picShape.TopLeftCell, cellRng) Is Nothing Then

                Set getCellShape = picShape

                Exit Function

            End If

        End If

    Next

    Set getCellShape = Nothing

End Function

三、vba根据新表编号从旧表复制图片到新表列

Sub vba将Excel原表编号对应行图片复制到新表()

    Dim btnShape As Shape

    For Each btnShape In ActiveSheet.Shapes

        If Not btnShape.Name Like "Button*" Then btnShape.Delete

    Next

    Dim startRow As Integer, endRow As Integer, i As Integer

    startRow = 2: endRow = ActiveSheet.[A65535].End(xlUp).Row

    Dim findRng As Range

    Dim rngTop As Variant, rngHeight As Variant

    Dim picShape As Shape

    For i = startRow To endRow

        With Sheets("名单")

            Set findRng = .Range("A:A").Find(ActiveSheet.Range("A" & i), lookat:=xlWhole)

            If Not findRng Is Nothing Then

            rngTop = findRng.Top

            rngHeight = findRng.Height

            For Each picShape In .Shapes

              If picShape.Top > rngTop - 5 And picShape.Top + picShape.Height < rngTop + rngHeight + 5 Then

              picShape.Copy

              ActiveSheet.Range("C" & i).Select

              ActiveSheet.Paste

              End If

            Next

            End If

        End With

    Next

End Sub

欢迎交流分享，联系qq：329876601