批量將圖片插入到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，還有什麼……想不起來了，就先醬紫吧，揮手致安~

嗯，以下是示例文件~

.

https://pan.baidu.com/s/1ClgLjzXe0K9WOIPbxDPDhg#list/path=%2F

圖文作者：看見星光