如果sheet1 有多张图片，即命名为“Excel表名（1）,Excel表名（2）”这样循环

效果动态图：

详细VBA源码：

Sub 保存图片()

Dim MyPath$, myFolder$, myName$

Dim wb As Workbook, Sh As Worksheet, shp As Shape, m%, n%

Application.ScreenUpdating = False

Application.DisplayAlerts = False

MyPath = ThisWorkbook.Path

myFolder = MyPath & "\图片\"

If Len(Dir(myFolder, vbDirectory)) = 0 Then MkDir myFolder

myName = Dir(MyPath & "\*.xls", vbDirectory)

Do While myName <> ""

If myName <> ThisWorkbook.Name Then

n = 0

Set wb = Workbooks.Open(MyPath & "\" & myName) 'Filename:=MyPath & "\" & myName '& ".xls" ', Password:=""

For Each Sh In wb.Sheets

For Each shp In Sh.Shapes

n = n + 1

shp.CopyPicture

With Sh.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart

.Paste

.Export myFolder & myName & "(" & n & ").JPG", "JPG"

.Parent.Delete

End With

Next

Next

wb.Close savechanges:=False

End If

m = m + n

myName = Dir

Loop

MsgBox "保存了 " & m & "张图片"

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub