怎样使用VBA在不连续单元格中批量插入图片？

1、首先在开发工具中打开VBA编辑器

2、在单元格区域当中输入一些内容作为例子

3、在VBA编辑器中插入模块

4、在模块当中输入如下代码，然后运行

Sub 单元格插入图片()

 

On Error Resume Next        '出错继续执行后面的代码

 

Dim M As Range, fd, t

 

Dim i As Long

Set fd = Application.FileDialog(msoFileDialogFolderPicker)      '允许用户选择一个文件夹

 

If fd.Show = -1 Then

 

      t = fd.SelectedItems(1)

 

    Else

 

      Exit Sub

 

    End If

 

   

 

'For Each M In Selection

 

For i = 0 To 5

 

'For Each M In Cells(6 + i * 8, 2)

 

For Each M In Range("B" & (6 + i * 8) & ":G" & (7 + i * 8))

 

  If Not IsEmpty(M) Then

 

       

 

        Set M = M.TopLeftCell             '根据图片的左上角的位置判断单元格的位置

 

        If M.MergeCells = True Then                '如果图片所在的单元格为合并单元格那么

 

        MT = M.MergeArea.Top + 10      '图片的顶部位置等于合并单元格的顶部向下1.5

 

        ML = M.MergeArea.Left + 10    '图片左边位置等于合并单元格左边向右1. 5

 

        '上面两句实际上就是把图片给移动了-下

 

        MW = M.MergeArea.Width - 20    '图片的宽度等于合并单元格的宽度减少-3 .

 

        MH = M.MergeArea.Height - 20  '图片的高度等于合并单元格的高度咸少-3

 

        Else        '否则就是说如果图片所在的位置不是合并单元格就根据下面的代码去调整

 

        MT = M.Top + 10            '顶部位置

 

        ML = M.Left + 10          '左侧位置

 

        MW = M.Width - 20          '宽度

 

        MH = M.Height - 20        '高度

 

        '这部分实际上和上面的是- 样的我就不具体写了

 

        End If  '结束判断

 

 

 

    'Set M = shapeTemp.TopLeftCell

 

    'M.MergeArea.Select

 

    'ML = M.MergeArea.Left + 10      '图片的顶部位置等于单元格的顶部向下10

 

    'MT = M.MergeArea.Top + 10       '图片的左边位置等于单元格的左边向右10

 

    'MW = M.MergeArea.Width - 20     '图片的宽度等于单元格的宽度减少-20

 

    'MH = M.MergeArea.Height - 20    '图片的高度等于单元格的高度咸少-20

 

   

 

    ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select

 

    Selection.ShapeRange.LockAspectRatio = msoFalse

 

    Selection.ShapeRange.Fill.UserPicture t & "\" & M.Text & ".jpg"     '当前文件所在目录下以当前单元内容为名称的.jpg图片

 

   

 

   End If

 

Next

 

Next

 

End Sub

5、最后就可以看到我们成功的在相应的单元格当中批量的插入了图片，