【Excel VBA】按名称一键将图片批量插入到单元格批注中

诸君好……
有朋友在后台提了这样一个问题，能不能根据名称一键将图片批量插入到单元格的批注中去，酱紫的话，当鼠标划过单元格，Excel就会自动显示图片了，很酷很实用……
比如下面动态图所展示的这样：

哎呦，不错哦~~

实现代码如下：

Sub AddCommentPic()

复制代码

Dim arr, i&, k&, n&, b As Boolean

复制代码

Dim strPicName$, strPicPath$, strFdPath$

复制代码

Dim rngData As Range, rngEach As Range

复制代码

'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)

复制代码

'用户选择需要插入图片到批注中的单元格或区域

复制代码

If rngData.Count = 0 Then Exit Sub

复制代码

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

复制代码

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

复制代码

If rngData Is Nothing Then MsgBox "选择单元格不能全为空。": Exit Sub

复制代码

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

复制代码

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

复制代码

Application.ScreenUpdating = False

复制代码

For Each rngEach In rngData

复制代码

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

复制代码

If Not rngEach.Comment Is Nothing Then rngEach.Comment.Delete '删除旧的批注

复制代码

strPicName = rngEach.Text '图片名称

复制代码

If Len(strPicName) Then '如果单元格存在值

复制代码

strPicPath = strFdPath & strPicName '图片路径

复制代码

b = False 'pd变量标记是否找到相关图片

复制代码

For i = 0 To UBound(arr)

复制代码

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

复制代码

If Len(Dir(strPicPath & arr(i))) Then

复制代码

'如果存在相关文件

复制代码

rngEach.AddComment '增加批注

复制代码

With rngEach.Comment

复制代码

.Visible = True '批注可见

复制代码

.Text Text:=""

复制代码

.Shape.Select True '选中批注图形

复制代码

Selection.ShapeRange.Fill.UserPicture strPicPath & arr(i)

复制代码

'插入图片到批注中

复制代码

.Shape.Height = 150 '图形的高度，可以根据需要自己调整

复制代码

.Shape.Width = 150 '图形的宽度，可以根据需要自己调整

复制代码

.Visible = False '取消显示

复制代码

End With

复制代码

b = True '标记找到结果

复制代码

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

复制代码

Exit For '找到结果后就可以退出文件格式循环

复制代码

End If

复制代码

Next

复制代码

If b = False Then k = k + 1 '如果没找到图片累加个数

复制代码

End If

复制代码

Next

复制代码

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

复制代码

Application.ScreenUpdating = True

复制代码

End Sub

复制代码

小贴士：
1，代码运行后，首先弹出操作界面，要求用户选择图片所存放的文件夹，注意是选择文件夹，不是选择图片，双击打开文件夹后看不到图片是正常现象……。
2，图片的名称需要和单元格的值相匹配；小代码如果找不到单元格的值所对应的图片，会直接跳过，处理下一个单元格；代码运行结束后，会发出信息，告知一共处理成功了几个图片以及未成功几个非空单元格的图片。

3，代码中使用了intersect语句，Set Rng = Intersect(Rng.Parent.UsedRange, Rng)，因此用户可以选择整列（比如整个A列）或多列单元格区域运行代码，而不用担心因为无谓的运算量过大，造成程序假死的情况。
4，代码导入的图片格式支持五种常见的类型，Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")
5，批注图片的高度和宽度可以根据自身情况做调整，相关代码如下：
.Shape.Height = 150 \'图形的高度，可以根据需要自己调整
.Shape.Width = 150 \'图形的宽度，可以根据需要自己调整
握爪，下期见啦~
模版下载：https://pan.baidu.com/s/1aW4S_eAOvDOP3pVFCr3sFA
提取码：eyfy