以下文章來(lái)源于VBA編程學(xué)習(xí)與實(shí)踐 ，作者EH看見星光

咱們今天分享的內(nèi)容是按指定名稱和位置批量將圖片插入到Excel工作表中……

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

代碼如下

Sub InsertPic() 
    'ExcelHome VBA編程學(xué)習(xí)與實(shí)踐 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("請(qǐng)選擇圖片名稱所在的單元格區(qū)域", Type:=8) 
    '用戶選擇需要插入圖片的名稱所在單元格范圍 
    Set Rng = Intersect(Rng.Parent.UsedRange, Rng) 
    'intersect語(yǔ)句避免用戶選擇整列單元格，造成無(wú)謂運(yùn)算的情況 
    If Rng Is Nothing Then MsgBox "選擇的單元格范圍不存在數(shù)據(jù)！": Exit Sub 
    strWhere = InputBox("請(qǐng)輸入圖片偏移的位置，例如上1、下1、左1、右1", , "右1") 
    '用戶輸入圖片相對(duì)單元格的偏移位置。 
    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 
    '如果舊圖片存放在目標(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è)單元格 
        strPicName = Cll.Text 
        '圖片名稱 
        If Len(strPicName) Then 
        '如果單元格存在值 
            strPicPath = strFdPath & strPicName 
            '圖片路徑 
            pd = 0 
            'pd變量標(biāo)記是否找到相關(guān)圖片 
            For i = 0 To UBound(Arr) 
            '由于不確定用戶的圖片格式，因此遍歷圖片格式 
                If Len(Dir(strPicPath & Arr(i))) Then 
                '如果存在相關(guān)文件 
                    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 '標(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 '如果沒(méi)找到圖片累加個(gè)數(shù) 
        End If 
    Next 
    Application.ScreenUpdating = True 
    MsgBox "共處理成功" & n & "個(gè)圖片，另有" & k & "個(gè)非空單元格未找到對(duì)應(yīng)的圖片。" 
End Sub 

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

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

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

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

小貼士：

1. 該段小代碼支持一下圖片格式：".jpg", ".jpeg", ".bmp", ".png", ".gif"
2. 圖片的縱橫比是未鎖定的，如需鎖定，可以注釋掉下句代碼：.ShapeRange.LockAspectRatio = msoFalse
3. 圖片的行高和列寬是由放置圖片的單元格行高和列寬決定的。當(dāng)然，您也可以把代碼稍微修改，設(shè)置固定的圖片行高和列寬，并由圖片的行高和列寬決定單元格的大小。
4. 圖片的名稱必須和指定單元格范圍內(nèi)的名稱一致，如果需要模糊匹配，使用DIR函數(shù)搭配通配符的方式即可。
5. 代碼采用非引用的方式插入圖片，該方式會(huì)圖片作為excel的資源打包到excel文件中，即便數(shù)據(jù)源的圖片已被刪除，表格中的圖片也依然存在。