单元格中的图片另存并且命名

学的多忘得多

制作一段VBA代码，适用于Excel表格，名称叫图片另存命名，要求根据B列嵌入单元格的图片和A列的名称，可以自动提取B列的原图，另存到电脑桌面，图片名称以对应的A列的值为名称，如果有重复的值，则仅保留一张图片，如果碰到单元格没有图片的，就自动跳过。
用豆包生成了下面这段代码，可以运行，但是在桌面没有图片导出来，不知道是导出失败了，还是导到其他地方去了。请大神给我看看，我用的是WPS版本的。


Sub 图片另存命名()
    Dim ws As Worksheet, shp As Shape, rng As Range
    Dim picPath As String, picName As String, existPath As String
    Set ws = ActiveSheet '当前工作表
    picPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" '桌面路径
   
    For Each rng In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) '遍历B列有数据区域（从B2开始）
        picName = Trim(rng.Offset(0, -1).Value) '获取对应A列名称
        existPath = picPath & picName & ".png" '图片保存路径及名称（默认PNG格式）
        
        If picName = "" Or Dir(existPath) <> "" Then GoTo NextRng 'A列空或图片已存在，跳过
        
        For Each shp In ws.Shapes '遍历工作表图片
            '判断图片是否嵌入当前B列单元格且未被处理过
            If shp.TopLeftCell.Address = rng.Address And shp.Name <> "已处理_" & picName Then
                shp.Copy '复制图片
                With CreateObject("Excel.Application").Workbooks.Add.Worksheets(1)
                    .Paste '粘贴图片
                    .Shapes(.Shapes.Count).CopyPicture '复制粘贴后的图片
                    With .ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart '创建临时图表
                        .Parent.Select: .Paste '粘贴到图表
                        .Export Filename:=existPath, FilterName:="PNG" '导出图片
                        .Parent.Delete '删除临时图表
                    End With
                    .Parent.Close SaveChanges:=False '关闭临时工作簿
                End With
                shp.Name = "已处理_" & picName '标记已处理图片，避免重复导出
                Exit For
            End If
        Next shp
NextRng:
    Next rng
    MsgBox "图片提取完成，已保存至桌面！"
End Sub

学的多忘得多

Sub 图片另存命名()
    Dim ws As Worksheet, shp As Shape, rng As Range
    Dim picPath As String, picName As String, existPath As String
    Set ws = ActiveSheet '当前工作表
    picPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" '桌面路径
   
    For Each rng In ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) '遍历B列有数据区域（从B2开始）
        picName = Trim(rng.Offset(0, -1).Value) '获取对应A列名称
        existPath = picPath & picName & ".png" '图片保存路径及名称（默认PNG格式）
        
        If picName = "" Or Dir(existPath) <> "" Then GoTo NextRng 'A列空或图片已存在，跳过
        
        For Each shp In ws.Shapes '遍历工作表图片
            '判断图片是否嵌入当前B列单元格且未被处理过
            If shp.TopLeftCell.Address = rng.Address And shp.Name <> "已处理_" & picName Then
                shp.Copy '复制图片
                With CreateObject("Excel.Application").Workbooks.Add.Worksheets(1)
                    .Paste '粘贴图片
                    .Shapes(.Shapes.Count).CopyPicture '复制粘贴后的图片
                    With .ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart '创建临时图表
                        .Parent.Select: .Paste '粘贴到图表
                        .Export Filename:=existPath, FilterName:="PNG" '导出图片
                        .Parent.Delete '删除临时图表
                    End With
                    .Parent.Close SaveChanges:=False '关闭临时工作簿
                End With
                shp.Name = "已处理_" & picName '标记已处理图片，避免重复导出
                Exit For
            End If
        Next shp
NextRng:
    Next rng
    MsgBox "图片提取完成，已保存至桌面！"
End Sub

逍遥爱迪生

AI经常骗人的

ykcbf1100

工作表中没看到图片

学的多忘得多

ykcbf1100 发表于 2025-12-2 13:56
工作表中没看到图片

我这看到是有图片的呢

赵桢0611

WPS嵌入单元格图片导出，试试

学的多忘得多

赵桢0611 发表于 2025-12-2 21:17
WPS嵌入单元格图片导出，试试

顶礼膜拜！！！真的可以！！！太棒了！！！