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ū)域', Type:=8)
    '用戶選擇需要插入圖片的名稱所在單元格范圍
    Set Rng = Intersect(Rng.Parent.UsedRange, Rng)
    'intersect語句避免用戶選擇整列單元格,，造成無謂運(yùn)算的情況
    If Rng Is Nothing Then MsgBox '選擇的單元格范圍不存在數(shù)據(jù),！': 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
    '如果舊圖片存放在目標(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 '如果沒找到圖片累加個(gè)數(shù)
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox '共處理成功' & n & '個(gè)圖片，另有' & k & '個(gè)非空單元格未找到對應(yīng)的圖片,。'
End Sub