转载地址：https://blog.csdn.net/weixin_29463587/article/details/112680461?utm_medium=distribute.pc_relevant.none-task-blog-baidujs_baidulandingword-3&spm=1001.2101.3001.4242
可以选择图片所在的文件夹
可以选择图片名所在的单元格
可以选择图片放置的位置
我自己的需求：自动添加图片，单元格指定，图片放置的位置指定
1 Sub InsertPic() 2 3 'ExcelHome VBA编程学习与实践 by:看见星光 4 5 Dim Arr, i&, k&, n&, pd& 6 7 Dim PicName$, PicPath$, FdPath$, shp As Shape 8 9 Dim Rng As Range, Cll As Range, Rg As Range, book$ 10 11 'On Error Resume Next 12 13 '用户选择图片所在的文件夹 14 15 With Application.FileDialog(msoFileDialogFolderPicker) 16 17 .AllowMultiSelect = False '不允许多选 18 19 If .Show Then FdPath = .SelectedItems(1) Else: Exit Sub 20 21 End With 22 23 If Right(FdPath, 1) <> "\" Then FdPath = FdPath & "\" 24 25 Set Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8) 26 27 '用户选择需要插入图片的名称所在单元格范围 28 29 Set Rng = Intersect(Rng.Parent.UsedRange, Rng) 30 31 'intersect语句避免用户选择整列单元格，造成无谓运算的情况 32 33 If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit Sub 34 35 book = InputBox("请输入图片偏移的位置，例如上1、下1、左1、右1", , "右1") 36 37 '用户输入图片相对单元格的偏移位置。 38 39 If Len(book) = 0 Then Exit Sub 40 41 x = Left(book, 1) '偏移的方向 42 43 If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位。": Exit Sub 44 45 y = Val(Mid(book, 2)) '偏移的尺寸 46 47 Select Case x 48 49 Case "上" 50 51 Set Rg = Rng.Offset(-y, 0) 52 53 Case "下" 54 55 Set Rg = Rng.Offset(y, 0) 56 57 Case "左" 58 59 Set Rg = Rng.Offset(0, -y) 60 61 Case "右" 62 63 Set Rg = Rng.Offset(0, y) 64 65 End Select 66 67 Application.ScreenUpdating = False 68 69 Rng.Parent.Select 70 71 For Each shp In ActiveSheet.Shapes '如果旧图片存放在目标图片存放范围则删除 72 73 If Not Intersect(Rg, shp.TopLeftCell) Is Nothing Then shp.Delete 74 75 Next 76 77 x = Rg.Row - Rng.Row: y = Rg.Column - Rng.Column 78 79 '偏移的坐标 80 81 Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif") 82 83 '用数组变量记录五种文件格式 84 85 For Each Cll In Rng 86 87 '遍历选择区域的每一个单元格 88 89 PicName = Cll.Text '图片名称 90 91 If Len(PicName) Then '如果单元格存在值 92 93 PicPath = FdPath & PicName '图片路径 94 95 pd = 0 'pd变量标记是否找到相关图片 96 97 For i = 0 To UBound(Arr) 98 99 '由于不确定用户的图片格式，因此遍历图片格式 100 101 If Len(Dir(PicPath & Arr(i))) Then 102 103 '如果存在相关文件 104 105 ActiveSheet.Pictures.Insert(PicPath & Arr(i)).Select 106 107 '插入图片并选中 108 109 With Selection 110 111 .ShapeRange.LockAspectRatio = msoFalse 112 113 '撤销锁定纵横比 114 115 .Top = Cll.Offset(x, y).Top + 5 116 117 .Left = Cll.Offset(x, y).Left + 5 118 119 .Height = Cll.Offset(x, y).Height - 10 '图片高度 120 121 .Width = Cll.Offset(x, y).Width - 10 '图片宽度 122 123 End With 124 125 pd = 1 '标记找到结果 126 127 n = n + 1 '累加找到结果的个数 128 129 [a1].Select: Exit For '找到结果后就可以退出文件格式循环 130 131 End If 132 133 Next 134 135 If pd = 0 Then k = k + 1 '如果没找到图片累加个数 136 137 End If 138 139 Next 140 141 MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。" 142 143 Application.ScreenUpdating = True 144 145 End Sub