先說個(gè)事啊，近段時(shí)間會(huì)忙于《Excel 2016 VBA實(shí)戰(zhàn)技巧精粹》的書稿準(zhǔn)備工作，公眾號(hào)系列文章的推文會(huì)緩慢很多，比如VBA ADO SQL基礎(chǔ)教程以及新手學(xué)Excel入門系列等，握爪抱歉~

我們今天分享的內(nèi)容是按指定名稱和位置批量將圖片插入到Excel工作表中……這個(gè)問題后臺(tái)提問的朋友太多了，趕緊分享了事。

看個(gè)動(dòng)畫先：

代碼如下：

Sub InsertPic()

    'ExcelHome VBA編程學(xué)習(xí)與實(shí)踐 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('請(qǐng)選擇圖片名稱所在的單元格區(qū)域', Type:=8)

    '用戶選擇需要插入圖片的名稱所在單元格范圍

    Set Rng = Intersect(Rng.Parent.UsedRange, Rng)

    'intersect語句避免用戶選擇整列單元格，造成無謂運(yùn)算的情況

    If Rng Is Nothing Then MsgBox '選擇的單元格范圍不存在數(shù)據(jù)！': Exit Sub

    book = InputBox('請(qǐng)輸入圖片偏移的位置，例如上1、下1、左1、右1', , '右1')

    '用戶輸入圖片相對(duì)單元格的偏移位置。

    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 '如果舊圖片存放在目標(biāo)圖片存放范圍則刪除

        If Not Intersect(Rg, shp.TopLeftCell) Is Nothing Then shp.Delete

    Next

    x = Rg.Row - Rng.Row: y = Rg.Column - Rng.Column

    '偏移的坐標(biāo)

    Arr = Array('.jpg', '.jpeg', '.bmp', '.png', '.gif')

    '用數(shù)組變量記錄五種文件格式

    For Each Cll In Rng

    '遍歷選擇區(qū)域的每一個(gè)單元格

        PicName = Cll.Text '圖片名稱

        If Len(PicName) Then '如果單元格存在值

            PicPath = FdPath & PicName '圖片路徑

            pd = 0 'pd變量標(biāo)記是否找到相關(guān)圖片

            For i = 0 To UBound(Arr)

            '由于不確定用戶的圖片格式，因此遍歷圖片格式

                If Len(Dir(PicPath & Arr(i))) Then

                '如果存在相關(guān)文件

                    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 '標(biāo)記找到結(jié)果

                    n = n 1 '累加找到結(jié)果的個(gè)數(shù)

                    [a1].Select: Exit For '找到結(jié)果后就可以退出文件格式循環(huán)

                End If

            Next

            If pd = 0 Then k = k 1 '如果沒找到圖片累加個(gè)數(shù)

        End If

    Next

    MsgBox '共處理成功' & n & '個(gè)圖片，另有' & k & '個(gè)非空單元格未找到對(duì)應(yīng)的圖片。'

    Application.ScreenUpdating = True

End Sub

代碼已有注釋，這兒就再說明一下運(yùn)行過程。

首先，會(huì)讓用戶選擇存放圖片的文件夾。注意是選擇文件夾，不是選擇圖片；選擇文件夾后，看不到文件夾內(nèi)的圖片是正?，F(xiàn)象。

然后，選擇圖片名稱存放的單元格區(qū)域，可以選擇整列、多列、整行或多行，比如示例動(dòng)畫中的B:D列，2:2行等。。

最后，設(shè)置圖片相對(duì)于圖片名稱所在的單元格便宜的位置；比如圖片名稱在B列，圖片放在C列，那就是向右偏移1列，即右1。上下左右代表了方向，數(shù)字代表偏移的量。

代碼繼續(xù)運(yùn)行，先刪除存放于放置圖片單元格范圍的原圖片圖形（如何用代碼刪除指定位置的圖形圖片？這個(gè)問題也不要在后臺(tái)提問了），然后遍歷圖片名稱，根據(jù)偏移位置插入新圖片。

代碼運(yùn)行結(jié)束后會(huì)告之用戶一共成功插入了多少?gòu)垐D片，以及失敗了多少?gòu)?；有朋友說找不到圖片的單元格能否填充顏色作提醒，我想想覺得沒必要啊，就沒做……不要說我懶，認(rèn)真臉。

小貼士：

1，該段小代碼支持一下圖片格式：

'.jpg', '.jpeg', '.bmp', '.png', '.gif'

2，圖片的縱橫比是未鎖定的，如需鎖定，可以注釋掉下句代碼：

.ShapeRange.LockAspectRatio = msoFalse

3，圖片的行高和列寬是由放置圖片的單元格行高和列寬決定的。當(dāng)然，您也可以把代碼稍微修改，設(shè)置固定的圖片行高和列寬，并由圖片的行高和列寬決定單元格的大小。

4，圖片的名稱必須和指定單元格范圍內(nèi)的名稱一致，如果需要模糊匹配，使用DIR函數(shù)搭配通配符的方式即可。

5，還有什么……想不起來了，就先醬紫吧，揮手致安~