Excel批量导入图片到指定单元格

一、从excel图片批量嵌入单元格

在Excel中，我们可以将图片嵌入单元格中，这样可以保证图片与单元格的对应关系，也方便对单元格和图片的移动和复制。

Sub Insert_Picture_Into_Cell()
    Dim strPic As String
    strPic = Application.GetOpenFilename("Pictures (*.gif; *.jpg; *.bmp), *.gif;*.jpg;*.bmp", MultiSelect:=True)
    If strPic = "False" Then Exit Sub
    Dim cell As Range
    For Each cell In Selection
        If cell.Row = ActiveCell.Row Then
            cell.Select
            If Len(strPic) > 0 Then
                cell.Activate
                ActiveSheet.Pictures.Insert(strPic).Select
                With Selection.ShapeRange
                    .LockAspectRatio = msoTrue
                    .Width = cell.Width - 2
                    .Height = cell.Height - 2
                    .Top = cell.Top + 1
                    .Left = cell.Left + 1
                End With
            End If
        End If
    Next
End Sub

二、Excel批量导入多张图片并自动排版

如果我们需要一次性导入多张图片并自动排版，可以使用以下代码：

Sub Insert_Multiple_Pictures()
    Dim strPath As String
    strPath = "C:\Pictures\" '图片所在文件夹路径
    Dim imgExtension As String
    imgExtension = "*.jpg" '图片扩展名
    Dim rowIndex As Integer
    rowIndex = 1 '从第一行开始插入图片
    Dim colIndex As Integer
    colIndex = 1 '从第一列开始插入图片
    Dim picTop As Double
    picTop = Cells(rowIndex, colIndex).Top '图片顶部位置
    Dim picLeft As Double
    picLeft = Cells(rowIndex, colIndex).Left '图片左侧位置
    Dim picWidth As Double
    picWidth = Cells(rowIndex, colIndex).Width '图片宽度
    Dim picHeight As Double
    picHeight = Cells(rowIndex, colIndex).Height '图片高度
    Dim imgCount As Integer
    imgCount = 0 '已插入图片数量
    Dim pic As Picture
    For Each pic In ActiveSheet.Pictures
        pic.Delete
    Next pic
    Dim strFile As String
    strFile = Dir(strPath & imgExtension)
    Do While Len(strFile) > 0
        Set pic = ActiveSheet.Pictures.Insert(strPath & strFile)
        pic.Top = picTop
        pic.Left = picLeft
        pic.Width = picWidth
        pic.Height = picHeight
        If colIndex < 4 Then
            colIndex = colIndex + 1
        Else
            colIndex = 1
            rowIndex = rowIndex + 1
        End If
        If rowIndex > 20 Then Exit Do '插入图片20张后退出
        picTop = Cells(rowIndex, colIndex).Top
        picLeft = Cells(rowIndex, colIndex).Left
        picWidth = Cells(rowIndex, colIndex).Width
        picHeight = Cells(rowIndex, colIndex).Height
        strFile = Dir
        imgCount = imgCount + 1
    Loop
    MsgBox imgCount & "张图片已成功导入到Excel中！"
End Sub

三、Excel批量导入对应图片

如果我们有一份表格，需要根据表格中每行数据对应的图片来批量导入图片，可以使用以下代码：

Sub Insert_Picture_By_Match()
    Dim strPath As String
    strPath = "C:\Pictures\" '图片所在文件夹路径
    Dim imgExtension As String
    imgExtension = "*.jpg" '图片扩展名
    Dim picTop As Double
    picTop = 0 '图片顶部位置
    Dim picLeft As Double
    picLeft = 0 '图片左侧位置
    Dim picWidth As Double
    picWidth = 100 '图片宽度
    Dim picHeight As Double
    picHeight = 100 '图片高度
    Dim i As Integer
    Dim j As Integer
    Dim strFile As String
    strFile = Dir(strPath & imgExtension)
    For i = 2 To 10 '从第2行开始
        picTop = ActiveSheet.Cells(i, 3).Top '图片所在行第3列
        picLeft = ActiveSheet.Cells(i, 4).Left '图片所在行第4列
        strFile = Dir(strPath & Left(ActiveSheet.Cells(i, 5).Value, 3) & imgExtension) '根据数据中的名称匹配图片
        Set pic = ActiveSheet.Pictures.Insert(strPath & strFile)
        pic.Top = picTop
        pic.Left = picLeft
        pic.Width = picWidth
        pic.Height = picHeight
    Next i
    MsgBox "图片已成功导入到Excel中！"
End Sub

四、Excel中快速批量导入图片

如果我们只需要快速地将图片批量导入到Excel中，可以使用以下方法：

在Excel中，我们可以直接通过复制粘贴的方式将图片导入到单元格中。

步骤如下：

1.打开图片文件夹和Excel表格文件，分别在Windows资源管理器和Excel中选中需要导入图片的单元格；

2.在资源管理器中选中需要导入的图片文件，使用Ctrl+C复制或者右键菜单复制；

3.在Excel表格中单击需要导入图片的单元格，使用Ctrl+V粘贴或者右键菜单粘贴。

五、Excel批量导入图片对应名称

如果我们有一批图片，需要将图片名称对应到Excel表格中的姓名列，可以使用以下代码：

Sub Insert_Picture_By_Name()
    Dim strPath As String
    strPath = "C:\Pictures\" '图片所在文件夹路径
    Dim imgExtension As String
    imgExtension = "*.jpg" '图片扩展名
    Dim imgCount As Integer
    imgCount = 0 '导入图片数量
    Dim strFile As String
    strFile = Dir(strPath & imgExtension)
    Dim r As Range
    For Each r In ActiveSheet.Range("A1:A10") '以A1:A10范围内的姓名为图片名称
        strFile = Dir(strPath & Left(r.Value, 3) & imgExtension)
        Set pic = ActiveSheet.Pictures.Insert(strPath & strFile)
        pic.Top = r.Top
        pic.Left = r.Left + r.Width + 5 '将图片放在姓名列的右侧5个单元格
        pic.Width = 100
        pic.Height = 100
        imgCount = imgCount + 1
    Next r
    MsgBox imgCount & "张图片已成功导入到Excel中！"
End Sub

六、Excel批量导入图片按姓名并选取

如果我们需要将图片按姓名进行导入，并且可以手动选取图片，可以使用以下代码：

Sub Insert_Picture_By_Select()
    Dim strPath As String
    strPath = "C:\Pictures\" '图片所在文件夹路径
    Dim imgExtension As String
    imgExtension = "*.jpg" '图片扩展名
    Dim imgCount As Integer
    imgCount = 0 '导入图片数量
    Dim strFile As String
    strFile = Dir(strPath & imgExtension)
    Dim r As Range
    For Each r In ActiveSheet.Range("A1:A10") '以A1:A10范围内的姓名为图片名称
        strFile = Dir(strPath & Left(r.Value, 3) & imgExtension)
        If Len(strFile) = 0 Then
            MsgBox "未找到名为" & Left(r.Value, 3) & "的照片。"
            Exit Sub
        End If
        Dim pic As Picture
        Set pic = ActiveSheet.Pictures.Insert(strPath & strFile)
        pic.Top = r.Top
        pic.Left = r.Left + r.Width + 5 '将图片放在姓名列的右侧5个单元格
        pic.Width = 100
        pic.Height = 100
        imgCount = imgCount + 1
        Dim picPath As String
        picPath = strPath & strFile
        Set pic = Nothing
        strFile = Dir
        ActiveSheet.Shapes.Range(Array(pic.Name)).OnAction = "Select_Picture('" & picPath & "')"
    Next r
    MsgBox imgCount & "张图片已成功导入到Excel中！"
End Sub

Function Select_Picture(picPath)
    Dim pic As Picture
    Set pic = ActiveSheet.Pictures.Insert(picPath)
    pic.Top = ActiveCell.Top
    pic.Left = ActiveCell.Left
    pic.Width = ActiveCell.Width
    pic.Height = ActiveCell.Height
    Set pic = Nothing
End Function