以下文章來源于VBA編程學習與實踐 ，作者EH看見星光
咱們今天分享的內容是按指定名稱和位置批量將圖片插入到Excel工作表中……
看個動畫先：
代碼如下
Sub InsertPic()
'ExcelHome VBA編程學習與實踐 by:看見星光
Dim Arr, i&, k&, n&, pd&
Dim strPicName$, strPicPath$, strFdPath$, shp As Shape
Dim Rng As Range, Cll As Range, Rg As Range, strWhere As String
'On Error Resume Next
'用戶選擇圖片所在的文件夾
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then strFdPath = .SelectedItems(1) Else: Exit Sub
End With
If Right(strFdPath, 1) <> "" Then strFdPath = strFdPath & ""
Set Rng = Application.InputBox("請選擇圖片名稱所在的單元格區域", Type:=8)
'用戶選擇需要插入圖片的名稱所在單元格范圍
Set Rng = Intersect(Rng.Parent.UsedRange, Rng)
'intersect語句避免用戶選擇整列單元格，造成無謂運算的情況
If Rng Is Nothing Then MsgBox "選擇的單元格范圍不存在數據！": Exit Sub
strWhere = InputBox("請輸入圖片偏移的位置，例如上1、下1、左1、右1", , "右1")
'用戶輸入圖片相對單元格的偏移位置。
If Len(strWhere) = 0 Then Exit Sub
x = Left(strWhere, 1)
'偏移的方向
If InStr("上下左右", x) = 0 Then MsgBox "你未輸入偏移方位。": Exit Sub
y = Val(Mid(strWhere, 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
'遍歷選擇區域的每一個單元格
strPicName = Cll.Text
'圖片名稱
If Len(strPicName) Then
'如果單元格存在值
strPicPath = strFdPath & strPicName
'圖片路徑
pd = 0
'pd變量標記是否找到相關圖片
For i = 0 To UBound(Arr)
'由于不確定用戶的圖片格式，因此遍歷圖片格式
If Len(Dir(strPicPath & Arr(i))) Then
'如果存在相關文件
Set shp = ActiveSheet.Shapes.AddPicture( _
strPicPath & Arr(i), False, True, _
Cll.Offset(x, y).Left + 5, _
Cll.Offset(x, y).Top + 5, _
20, 20)
shp.Select
With Selection
.ShapeRange.LockAspectRatio = msoFalse
'撤銷鎖定圖片縱橫比
.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
Application.ScreenUpdating = True
MsgBox "共處理成功" & n & "個圖片，另有" & k & "個非空單元格未找到對應的圖片。"
End Sub
代碼已有注釋說明，這兒就再說明一下運行過程。
首先，會讓用戶選擇存放圖片的文件夾。注意是選擇文件夾，不是選擇圖片；選擇文件夾后，看不到文件夾內的圖片是正常現象。
然后，選擇圖片名稱存放的單元格區域，可以選擇整列、多列、整行或多行，比如示例動畫中的B:D列，2:2行等。。
最后，設置圖片相對于圖片名稱所在的單元格便宜的位置；比如圖片名稱在B列，圖片放在C列，那就是向右偏移1列，即右1。上下左右代表了方向，數字代表偏移的量。
小貼士：
1，該段小代碼支持一下圖片格式：
".jpg", ".jpeg", ".bmp", ".png", ".gif"
2，圖片的縱橫比是未鎖定的，如需鎖定，可以注釋掉下句代碼：
.ShapeRange.LockAspectRatio = msoFalse
3，圖片的行高和列寬是由放置圖片的單元格行高和列寬決定的。當然，您也可以把代碼稍微修改，設置固定的圖片行高和列寬，并由圖片的行高和列寬決定單元格的大小。
4，圖片的名稱必須和指定單元格范圍內的名稱一致，如果需要模糊匹配，使用DIR函數搭配通配符的方式即可。
5，代碼采用非引用的方式插入圖片，該方式會圖片作為excel的資源打包到excel文件中，即便數據源的圖片已被刪除，表格中的圖片也依然存在。
