Excel使用VBA实现单元格内输入内容即可插入对应名称图片的功能

最近使用Excel时遇到了需要批量插入图片的任务，并且图片重复性很高，数量有几百张，每一张插入后都要手动调整图片大小，于是就想有没有一种方法可以快速插入图片并且自动居中，在网上查找了多个方法，有的只是实现自动居中、有的只是插入的图片链接，脱离自己的电脑后图片就无法显示了、还有的只是针对具体的行列进行插入，局限性很大，因此，我综合了几个方法代码后，编写了如下代码，可以实现任意单元格插入图片并且自动居中，同时将将目标单元格内的旧图片删除覆盖！

 

现将代码分享一下，请各位酌情使用，如有可以优化的地方也请提出，大家一起学习！

Private Sub Worksheet_Change(ByVal Target As Range)

Dim i, j, arr, str, typ, shp

Dim filpath As String

Dim shpPic As Shape

Dim cellW As Single, cellH As Single '单元格的宽和高

 

Dim cellL As Single, cellT As Single '单元格的左边和上边位置（左上角）

On Error Resume Next '忽略运行中可能出现的错误

Application.EnableEvents = False '关闭触发连锁事件

Application.ScreenUpdating = False '关闭工作表更新，提高运行速度

' If Target.Count <> 1 Then Exit Sub

 

'If Len(Target) = 0 Then Exit Sub

If Target.Row < 1000 And Target.Column < 1000 And Target.Count = 1 Then '如果改变的单元格在A1:A999且只是1个单元格，则

i = Target.Column '追踪单元格所在的列

j = Target.Row '追踪单元格所在的行

For Each shp In ActiveSheet.Shapes '扫描工作表里面的每一张图片

If Not Application.Intersect(Target, shp.TopLeftCell) Is Nothing Then

shp.Delete '如果追踪到所选单元格里边的图片，则删除旧图片

End If

Next

cellL = Target.Left '目标图片插入后对应单元格的左上角位置

 

cellT = Target.Top '目标图片插入后对应单元格的顶部位置

 

cellW = 85 '目标图片插入后的宽

 

cellH = 82 '目标图片插入后的高

If Target.Value <> "" Then '如果目标单元格内容不为空，则执行

 

filpath = ThisWorkbook.Path & "\样本\" & Target & ".gif" '“\样本\”为图片所在的文件夹名称、“.gif”为图片格式，这两项需要根据实际情况修改，但要注意，放置图片的文件夹需要和Excel文档放在同一个文件夹下

 

Set shpPic = ActiveSheet.Shapes.AddPicture(filpath, msoFalse, msoTrue, cellL, cellT, cellW, cellH) '用AddPicture方法插入图片，括号内表示（图片路径, 图片副本，图片随文档保存，左，顶，宽，高）

 

shpPic.Select ' 选择插入后的图片

 

With Selection

.Name = Target '定义图片插入后的名称

 

.ShapeRange.LockAspectRatio = msoFalse '取消图片锁定纵横比

.Width = Selection.Width * 0.35 '图片插入单元格后的宽为原图片的0.35倍，可根据实际需要修改

 

.Height = Selection.Height * 0.33 '图片插入单元格后的宽为原图片的0.33倍，可根据实际需要修改

 

.Top = (Target.Height - Selection.Height) / 2 + Target.Top '图片上下居中

 

.Left = (Target.Width - Selection.Width) / 2 + Target.Left '图片左右居中

 

End With

 

Else

 

'Target.Value = "图片不存在"

 

End If

 

End If

Application.ScreenUpdating = True '恢复更新显示

Application.EnableEvents = True '恢复触发连锁事件

End Sub