按名称批量将图片插入到表格中？So Easy！

小代码支持跨工作簿处理图片，另外模版下载即可使用。只需要下载并打开模版，点击运行按钮，按照系统提示选择存放图片的文件夹，保存图片的工作表区域即可。

还是简单说明一下代码运行过程。

▎单击工作表中硕大的运行按钮后，Excel会弹出一个对话框，让你来选择存放图片的文件夹。注意是选择文件夹，不是选择图片；选定文件夹后，看不到文件夹内的图片是正常现象。

▎然后选择图片名称存放的单元格区域，可以选择整列、多列、整行或多行，比如示例动画中的B:D列，2:2行等。选定的范围可以跨表，也可以跨工作簿。

▎最后设置图片相对于图片名称所在的单元格偏移的位置；比如图片名称在B列，图片放在C列，那就是向右偏移1列，即右1。上下左右代表了方向，数字代表偏移的量。

代码继续运行，会先删除旧图片，再插入新图片，最后发出一个消息框，用户一共成功插入了多少张图片，失败了多少张；有朋友说找不到图片的单元格能否填充颜色作提醒，我想想觉得没必要啊，就没做……不要说我懒，认真脸，因为我本来就真的很懒。

小贴士

不是必须了解的

▎1>该段小代码支持以下图片格式：

'.jpg', '.jpeg', '.bmp', '.png', '.gif'

▎2>图片的纵横比是未锁定的，如需锁定，可以注释掉以下代码：

.ShapeRange.LockAspectRatio = msoFalse

▎3>图片的行高和列宽是由放置图片的单元格行高和列宽决定的。当然，您也可以把代码稍微修改，设置固定的图片行高和列宽，并由图片的行高和列宽决定单元格的大小。

▎4>图片的名称必须和指定单元格范围内的名称一致，如果需要模糊匹配，可以使用DIR函数搭配通配符的方式。

▎5>代码采用非引用的方式插入图片，该方式会将图片作为资源打包到excel文件中，即便数据源的图片已被删除，表格中的图片也依然存在，这样有利于将工作簿发送他人，不利是Excel体积过大，使用效率就会变差。

代码如下：

Sub InsertPic()    Dim arr, i&, k&, n&, b As Boolean    Dim strPicName$, strPicPath$, strFdPath$, shp As Shape    Dim rngData As Range, rngEach As Range, rngWhere As Range, strWhere As String    'On Error Resume Next    '用户选择图片所在的文件夹    With Application.FileDialog(msoFileDialogFolderPicker)       If .Show Then strFdPath = .SelectedItems(1) Else: Exit Sub    End With    If Right(strFdPath, 1) <> '\' Then strFdPath = strFdPath & '\'    Set rngData = Application.InputBox('请选择图片名称所在的单元格区域', Type:=8)    '用户选择需要插入图片的名称所在单元格范围    Set rngData = Intersect(rngData.Parent.UsedRange, rngData)    'intersect语句避免用户选择整列单元格，造成无谓运算的情况    If rngData Is Nothing Then MsgBox '选择的单元格范围不存在数据！': Exit Sub    strWhere = InputBox('请输入图片偏移的位置，例如上1、下1、左1、右1', , '右1')    '用户输入图片相对单元格的偏移位置。    If Len(strWhere) = 0 Then Exit Sub    x = Left(strWhere, 1)    '偏移的方向    If InStr('上下左右', x) = 0 Then MsgBox '你未输入偏移方位。': Exit Sub    y = Val(Mid(strWhere, 2))    '偏移的值    Select Case x        Case '上'        Set rngWhere = rngData.Offset(-y, 0)        Case '下'        Set rngWhere = rngData.Offset(y, 0)        Case '左'        Set rngWhere = rngData.Offset(0, -y)        Case '右'        Set rngWhere = rngData.Offset(0, y)    End Select    Application.ScreenUpdating = False    rngData.Parent.Parent.Activate '用户选定的激活工作簿    rngData.Parent.Select    For Each shp In ActiveSheet.Shapes    '如果旧图片存放在目标图片存放范围则删除        If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.Delete    Next    x = rngWhere.Row - rngData.Row    y = rngWhere.Column - rngData.Column    '偏移的坐标    arr = Array('.jpg', '.jpeg', '.bmp', '.png', '.gif')    '用数组变量记录五种文件格式    For Each rngEach In rngData    '遍历选择区域的每一个单元格        strPicName = rngEach.Text        '图片名称        If Len(strPicName) Then        '如果单元格存在值            strPicPath = strFdPath & strPicName            '图片路径            b = False            '变量标记是否找到相关图片            For i = 0 To UBound(arr)            '由于不确定用户的图片格式，因此遍历图片格式                If Len(Dir(strPicPath & arr(i))) Then                '如果存在相关文件                    Set shp = ActiveSheet.Shapes.AddPicture( _                        strPicPath & arr(i), False, True, _                        rngEach.Offset(x, y).Left + 5, _                        rngEach.Offset(x, y).Top + 5, _                        20, 20)                    shp.Select                    With Selection                        .ShapeRange.LockAspectRatio = msoFalse                        '撤销锁定图片纵横比                        .Height = rngEach.Offset(x, y).Height - 10 '图片高度                        .Width = rngEach.Offset(x, y).Width - 10 '图片宽度                    End With                    b = True '标记找到结果                    n = n + 1 '累加找到结果的个数                    Range('a1').Select: Exit For '找到结果后就可以退出文件格式循环                End If            Next            If b = False Then k = k + 1 '如果没找到图片累加个数        End If    Next    Application.ScreenUpdating = True    MsgBox '共处理成功' & n & '个图片，另有' & k & '个非空单元格未找到对应的图片。'End Sub