一、将公式定义成名称进行引用
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