Sub 导图并命名()

On Error Resume Next

Dim OutputAddress As String

Dim MySheet As Worksheet

Dim MyRange As Range

Dim h As Integer

Dim w As Integer

OutputAddress = ThisWorkbook.Path & "\" '输出文件夹地址

Set MySheet = Sheets("Sheet1") '图片所在工作表

For Each MyShape In MySheet.Shapes '遍历shape

    If MyShape.Type = 13 Then '若类型为图片

        Set MyRange = MyShape.TopLeftCell '获取图片左上角所在单元格

        If Not Application.Intersect(MyRange, Range("B：B")) Is Nothing Then '

            w = MyShape.Width

            h = MyShape.Height

            MyShape.ScaleHeight 1, msoCTrue

            MyShape.ScaleWidth 1, msoCTrue

            Set MyChart = MySheet.ChartObjects.Add(0, 0, MyShape.Width, MyShape.Height).Chart '新建chart对象，设置大小，粘贴图片

            MyShape.Copy

            MySheet.ChartObjects(Replace(MyChart.Name, MySheet.Name & " ", "")).Activate

            ActiveChart.Paste

            MyChart.Export OutputAddress & Cells(MyRange.Row, "A").Value & ".jpg", "JPG" '导出

            MyChart.Parent.Delete '删除chart对象

            MyShape.Width = w

            MyShape.Height = h

        End If

        Set MyRange = Nothing

    End If

Next MyShape

Application.ScreenUpdating = True

MsgBox "导出图片完成！" & Chr(13) & "导出图片所在的路径：" & Chr(13) & sfolder, , "提示"

End Sub

用这个也导不出来  ，求助求助

回复：3楼