轉載地址：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