VBA常用代码:如何在单元格中批量插入图片 |
您所在的位置:网站首页 › vba批量导入图片到某一列的文件 › VBA常用代码:如何在单元格中批量插入图片 |
转自:微点阅读 https://www.weidianyuedu.com/ 代码如下: 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函数搭配通配符的方式即可。(转自:微点阅读 https://www.weidianyuedu.com) |
今日新闻 |
推荐新闻 |
CopyRight 2018-2019 办公设备维修网 版权所有 豫ICP备15022753号-3 |