Sub SaveShapes()
    Dim iSht As Worksheet, iShape As Shape, EachShape As Shape
    Dim sFolderPath As String, oFSO As Object, sName As String
     
    Application.ScreenUpdating = False
    sFolderPath = ThisWorkbook.Path & "\"
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    For Each iSht In Worksheets 'каждый лист
        For Each iShape In iSht.Shapes 'каждый объект
'            If iShape.Type = msoGroup Then 'Если группа
'                For Each EachShape In iShape.GroupItems
                    If Not iShape.Name Like "*Oval*" And Not iShape.Name Like "*Rectangle*" And Not iShape.Name Like "*Line*" And Not iShape.Name Like "*Connector*" Then
                        If Not oFSO.folderexists(sFolderPath & iSht.Name) Then oFSO.CreateFolder (sFolderPath & iSht.Name)
                        sName = sFolderPath & iSht.Name & "\" & iShape.Name
                        iShape.Copy
                        With ActiveSheet.ChartObjects.Add(0, 0, iShape.Width, iShape.Height).Chart
                            .Parent.Select
                            .Paste
                            .Export Filename:=sName & ".jpg", FilterName:="jpg"
                            .Parent.Delete
                        End With
                    End If
'                Next EachShape
'            End If
        Next iShape
    Next iSht
    Application.ScreenUpdating = True
    MsgBox "Картинки сохранены!", vbInformation, "Конец"
End Sub