1、工作表中自动插入图片

根据X列的文件名，在Y列插入相同文件名的JPG图片，
代码运行后，会弹出会话框选择文件所在的文件夹，会扫描指定文件夹以及它的子文件夹

可自定义插入图片后的图片大小，插入图片后自动调整行高

有两个模块，一个是插入图片SUB，一个是删除图片SUB

Sub 插入图片()
    ' 声明变量
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim picturePath As String
    Dim pictureName As String
    Dim pic As Shape
    Dim fso As Object
    Dim folder As Object
    Dim pictureFile As String
    
    ' 自定义参数（可以根据需要修改这些值）
    Const NAME_COLUMN As String = "A"    ' 图片名称所在列
    Const INSERT_COLUMN As String = "C"  ' 插入图片的目标列
    Const PIC_WIDTH As Double = 50       ' 图片宽度（单位：像素）
    Const PIC_HEIGHT As Double = 50      ' 图片高度（单位：像素）
    Const ROW_HEIGHT_EXTRA As Double = 2 ' 行高额外增加的点数
    
    ' 设置工作表
    Set ws = ActiveSheet
    
    ' 获取名称列最后一行的行号
    lastRow = ws.Cells(ws.Rows.Count, NAME_COLUMN).End(xlUp).Row
    
    ' 让用户选择图片文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择包含图片的文件夹"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择文件夹，操作取消。"
            Exit Sub
        End If
        picturePath = .SelectedItems(1)
    End With
    
    ' 创建文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(picturePath)
    
    ' 遍历名称列的每一行
    For i = 1 To lastRow
        ' 获取名称列单元格的内容（图片名称，不包含扩展名）
        pictureName = ws.Cells(i, NAME_COLUMN).Value
        
        ' 查找匹配的图片文件
        pictureFile = FindPictureFile(folder, pictureName)
        
        If pictureFile <> "" Then
            ' 如果找到图片，则插入到指定列对应的单元格中
            Set pic = ws.Shapes.AddPicture(pictureFile, msoFalse, msoCTrue, _
                ws.Cells(i, INSERT_COLUMN).Left, ws.Cells(i, INSERT_COLUMN).Top, PIC_WIDTH, PIC_HEIGHT)
            
            ' 设置图片的位置和大小
            With pic
                .Left = ws.Cells(i, INSERT_COLUMN).Left
                .Top = ws.Cells(i, INSERT_COLUMN).Top
                ' 将图片锁定到单元格，但允许删除
                .Placement = xlFreeFloating
                ' 给图片添加独特的名称，便于后续操作
                .Name = "Picture_" & i
            End With
            
            ' 调整行高，使其比图片高度稍高
            ws.Rows(i).RowHeight = PIC_HEIGHT + ROW_HEIGHT_EXTRA
        Else
            ' 如果图片不存在，在指定列对应的单元格中显示"图片不存在"
            ws.Cells(i, INSERT_COLUMN).Value = "图片不存在"
        End If
    Next i
    
    ' 提示用户操作完成
    MsgBox "图片插入完成！", vbInformation
End Sub

Function FindPictureFile(folder As Object, fileName As String) As String
    Dim file As Object
    Dim subFolder As Object
    Dim extensions As Variant
    Dim ext As Variant
    
    ' 定义支持的图片格式
    extensions = Array(".jpg", ".jpeg", ".png", ".gif", ".bmp")
    
    ' 在当前文件夹中查找
    For Each file In folder.Files
        For Each ext In extensions
            If LCase(file.Name) = LCase(fileName & ext) Then
                FindPictureFile = file.Path
                Exit Function
            End If
        Next ext
    Next file
    
    ' 在子文件夹中递归查找
    For Each subFolder In folder.SubFolders
        FindPictureFile = FindPictureFile(subFolder, fileName)
        If FindPictureFile <> "" Then Exit Function
    Next subFolder
End Function



Sub 删除图片列()
    Dim ws As Worksheet
    Dim shp As Shape
    
    ' 设置工作表
    Set ws = ActiveSheet
    
    ' 遍历所有图形对象
    For Each shp In ws.Shapes
        ' 检查图形对象的名称是否以"Picture_"开头
        If Left(shp.Name, 8) = "Picture_" Then
            shp.Delete
        End If
    Next shp
    
    ' 提示用户操作完成
    MsgBox "图片已删除！", vbInformation
End Sub

不扫描子文件夹的版本

Sub 插入图片()
    ' 声明变量
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim picturePath As String
    Dim pictureName As String
    Dim pic As Shape
    Dim fso As Object
    Dim folder As Object
    Dim pictureFile As String
    
    ' 自定义参数（可以根据需要修改这些值）
    Const NAME_COLUMN As String = "A"    ' 图片名称所在列
    Const INSERT_COLUMN As String = "C"  ' 插入图片的目标列
    Const PIC_WIDTH As Double = 50       ' 图片宽度（单位：像素）
    Const PIC_HEIGHT As Double = 50      ' 图片高度（单位：像素）
    Const ROW_HEIGHT_EXTRA As Double = 2 ' 行高额外增加的点数
    
    ' 设置工作表
    Set ws = ActiveSheet
    
    ' 获取名称列最后一行的行号
    lastRow = ws.Cells(ws.Rows.Count, NAME_COLUMN).End(xlUp).Row
    
    ' 让用户选择图片文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择包含图片的文件夹"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "未选择文件夹，操作取消。"
            Exit Sub
        End If
        picturePath = .SelectedItems(1)
    End With
    
    ' 创建文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(picturePath)
    
    ' 遍历名称列的每一行
    For i = 1 To lastRow
        ' 获取名称列单元格的内容（图片名称，不包含扩展名）
        pictureName = ws.Cells(i, NAME_COLUMN).Value
        
        ' 查找匹配的图片文件
        pictureFile = FindPictureFile(folder, pictureName)
        
        If pictureFile <> "" Then
            ' 如果找到图片，则插入到指定列对应的单元格中
            Set pic = ws.Shapes.AddPicture(pictureFile, msoFalse, msoCTrue, _
                ws.Cells(i, INSERT_COLUMN).Left, ws.Cells(i, INSERT_COLUMN).Top, PIC_WIDTH, PIC_HEIGHT)
            
            ' 设置图片的位置和大小
            With pic
                .Left = ws.Cells(i, INSERT_COLUMN).Left
                .Top = ws.Cells(i, INSERT_COLUMN).Top
                ' 将图片锁定到单元格，但允许删除
                .Placement = xlFreeFloating
                ' 给图片添加独特的名称，便于后续操作
                .Name = "Picture_" & i
            End With
            
            ' 调整行高，使其比图片高度稍高
            ws.Rows(i).RowHeight = PIC_HEIGHT + ROW_HEIGHT_EXTRA
        Else
            ' 如果图片不存在，在指定列对应的单元格中显示"图片不存在"
            ws.Cells(i, INSERT_COLUMN).Value = "图片不存在"
        End If
    Next i
    
    ' 提示用户操作完成
    MsgBox "图片插入完成！", vbInformation
End Sub

Function FindPictureFile(folder As Object, fileName As String) As String
    ' 声明变量
    Dim file As Object
    Dim extensions As Variant
    Dim ext As Variant
    
    ' 定义支持的图片格式
    extensions = Array(".jpg", ".jpeg", ".png", ".gif", ".bmp")
    
    ' 仅在当前文件夹中查找
    For Each file In folder.Files
        ' 遍历所有支持的文件扩展名
        For Each ext In extensions
            ' 比较文件名（不区分大小写）
            If LCase(file.Name) = LCase(fileName & ext) Then
                ' 如果找到匹配的文件，返回完整路径
                FindPictureFile = file.Path
                ' 找到文件后立即退出函数
                Exit Function
            End If
        Next ext
    Next file
    
    ' 如果没有找到匹配的文件，返回空字符串
    FindPictureFile = ""
End Function

Sub 删除图片列()
    ' 声明变量
    Dim ws As Worksheet
    Dim shp As Shape
    
    ' 设置工作表
    Set ws = ActiveSheet
    
    ' 遍历所有图形对象
    For Each shp In ws.Shapes
        ' 检查图形对象的名称是否以"Picture_"开头
        If Left(shp.Name, 8) = "Picture_" Then
            ' 如果是，则删除该图形对象
            shp.Delete
        End If
    Next shp
    
    ' 提示用户操作完成
    MsgBox "图片已删除！", vbInformation
End Sub