VBA常用小代码：在单元格中批量插入图片

转载自品略图书馆 http://www.pinlue.com/article/2020/03/2914/4510066052758.html

代码如下：

Sub InsertPic()

"ExcelHome VBA编程学习与实践 by:看见星光

Dim Arr, i&, k&, n&, pd&

Dim PicName$, PicPath$, FdPath$, shp As Shape

Dim Rng As Range, Cll As Range, Rg As Range, book$

"On Error Resume Next

"用户选择图片所在的文件夹

With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False "不允许多选

If .Show Then FdPath = .SelectedItems(1) Else: Exit Sub

End With

If Right(FdPath, 1) <> "\" Then FdPath = FdPath & "\"

Set Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)

"用户选择需要插入图片的名称所在单元格范围

Set Rng = Intersect(Rng.Parent.UsedRange, Rng)

"intersect语句避免用户选择整列单元格，造成无谓运算的情况

If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit Sub

book = InputBox("请输入图片偏移的位置，例如上1、下1、左1、右1", , "右1")

"用户输入图片相对单元格的偏移位置。

If Len(book) = 0 Then Exit Sub

x = Left(book, 1) "偏移的方向

If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位。": Exit Sub

y = Val(Mid(book, 2)) "偏移的尺寸

Select Case x

Case "上"

Set Rg = Rng.Offset(-y, 0)

Case "下"

Set Rg = Rng.Offset(y, 0)

Case "左"

Set Rg = Rng.Offset(0, -y)

Case "右"

Set Rg = Rng.Offset(0, y)

End Select

Application.ScreenUpdating = False

Rng.Parent.Select

For Each shp In ActiveSheet.Shapes "如果旧图片存放在目标图片存放范围则删除

If Not Intersect(Rg, shp.TopLeftCell) Is Nothing Then shp.Delete

Next

x = Rg.Row - Rng.Row: y = Rg.Column - Rng.Column

"偏移的坐标

Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")

"用数组变量记录五种文件格式

For Each Cll In Rng

"遍历选择区域的每一个单元格

PicName = Cll.Text "图片名称

If Len(PicName) Then "如果单元格存在值

PicPath = FdPath & PicName "图片路径

pd = 0 "pd变量标记是否找到相关图片

For i = 0 To UBound(Arr)

"由于不确定用户的图片格式，因此遍历图片格式

If Len(Dir(PicPath & Arr(i))) Then

"如果存在相关文件

ActiveSheet.Pictures.Insert(PicPath & Arr(i)).Select

"插入图片并选中

With Selection

.ShapeRange.LockAspectRatio = msoFalse

"撤销锁定纵横比

.Top = Cll.Offset(x, y).Top + 5

.Left = Cll.Offset(x, y).Left + 5

.Height = Cll.Offset(x, y).Height - 10 "图片高度

.Width = Cll.Offset(x, y).Width - 10 "图片宽度

End With

pd = 1 "标记找到结果

n = n + 1 "累加找到结果的个数

[a1].Select: Exit For "找到结果后就可以退出文件格式循环

End If

Next

If pd = 0 Then k = k + 1 "如果没找到图片累加个数

End If

Next

MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。"

Application.ScreenUpdating = True

End Sub

代码已有注释，这儿就再说明一下运行过程。

首先，会让用户选择存放图片的文件夹。注意是选择文件夹，不是选择图片；选择文件夹后，看不到文件夹内的图片是正常现象。

然后，选择图片名称存放的单元格区域，可以选择整列、多列、整行或多行，比如示例动画中的B:D列，2:2行等。。

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

代码继续运行，先删除存放于放置图片单元格范围的原图片图形（如何用代码删除指定位置的图形图片？这个问题也不要在后台提问了），然后遍历图片名称，根据偏移位置插入新图片。

代码运行结束后会告之用户一共成功插入了多少张图片，以及失败了多少张；有朋友说找不到图片的单元格能否填充颜色作提醒，我想想觉得没必要啊，就没做……不要说我懒，认真脸。

小贴士：

1，该段小代码支持一下图片格式：

".jpg", ".jpeg", ".bmp", ".png", ".gif"

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

.ShapeRange.LockAspectRatio = msoFalse

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

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