先说个事啊,近段时间会忙于《Excel 2016 VBA实战技巧精粹》的书稿准备工作,公众号系列文章的推文会缓慢很多,比如VBA ADO SQL基础教程以及新手学Excel入门系列等,握爪抱歉~
我们今天分享的内容是按指定名称和位置批量将图片插入到Excel工作表中……这个问题后台提问的朋友太多了,赶紧分享了事。
看个动画先:
代码如下:
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函数搭配通配符的方式即可。
5,还有什么……想不起来了,就先酱紫吧,挥手致安~
联系客服