Option Explicit

Sub ImportGraphs()
Dim counter As Integer
Dim fileName As String
Dim i

Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlSheet As Object

Set xlApp = CreateObject("Excel.Application")

fileName = xlApp.GetOpenFilename("Excel Files (*.xls), *.xls")

If fileName Like "" Then
MsgBox ("Выберите файл для импортирования данных")
Else
xlApp.Workbooks.Open (fileName)

Set xlWorkbook = xlApp.ActiveWorkbook
xlApp.Visible = True

counter =  1 

For Each xlSheet In xlWorkbook.Sheets
 
  If xlSheet.Name Like "Диаграмма*" Then
      xlSheet.ChartArea.Copy
      ActivePresentation.Slides.Add(Index:=counter, Layout:=ppLayoutBlank).Select
      ActiveWindow.View.PasteSpecial ppPasteOLEObject, , , , , msoTrue
      counter = counter +  1 
    Else
     
     If xlSheet.ChartObjects.Count >  0  Then
       
       For i =  1  To xlSheet.ChartObjects.Count
         xlSheet.ChartObjects(i).Chart.ChartArea.Copy
         ActivePresentation.Slides.Add(Index:=counter, Layout:=ppLayoutBlank).Select
         ActiveWindow.View.PasteSpecial ppPasteOLEObject, , , , , msoTrue
         counter = counter +  1 
       Next
     
     End If
     
   End If
Next

End If

Set xlWorkbook = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub

Option Explicit
' Импортирует все графики в презентацию
Dim counter As Long
Sub ImportGraphs()
Dim fileName As String
Dim i

Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlSheet As Object

Set xlApp = CreateObject("Excel.Application")

fileName = xlApp.GetOpenFilename("Excel Files (*.xls), *.xls")

If fileName Like "" Then
MsgBox ("Выберите файл для импортирования данных")
Else
xlApp.Workbooks.Open (fileName)

Set xlWorkbook = xlApp.ActiveWorkbook
xlApp.Visible = True

counter =  1 

For Each xlSheet In xlWorkbook.Sheets
  If xlSheet.Name Like "Диаграмма*" Then
      xlSheet.ChartArea.Copy
      PasteGraphs
    Else
     If xlSheet.ChartObjects.Count >  0  Then
       For i =  1  To xlSheet.ChartObjects.Count
         xlSheet.ChartObjects(i).Chart.ChartArea.Copy
         PasteGraphs
       Next
     End If
     
   End If
Next

End If

Set xlWorkbook = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub

Sub PasteGraphs()
         
   ActivePresentation.Slides.Add(Index:=counter, Layout:=ppLayoutBlank).Select
   ActiveWindow.View.PasteSpecial ppPasteOLEObject, , , , , msoTrue
        
   ' изменение размера вставленного объекта
    With ActiveWindow.Selection.ShapeRange
        .ScaleWidth  1 . 2 , msoFalse, msoScaleFromBottomRight
        .ScaleHeight  1 . 2 , msoFalse, msoScaleFromBottomRight
        .ScaleWidth  1 . 2 , msoFalse, msoScaleFromTopLeft
        .ScaleHeight  1 . 2 , msoFalse, msoScaleFromTopLeft
    End With
    
    counter = counter +  1 

End Sub

            xlSheet.Range("Область_печати").Copy

Option Explicit
' Импортирует все графики в презентацию
Dim counter As Long
Sub ImportGraphsFromCloseFile()
Dim fileName As String
Dim i

Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim nm As Object

' тут ничего лучшего не предумал, т.к. для корректной работы макроса нужно, чтобы
' курсор стоял именно на слайде а не там где превьюшки
' поэтому на всякий случа передёргиваю режим
With Application.ActiveWindow
  ActiveWindow.ViewType = ppViewSlide
  ActiveWindow.ViewType = ppViewNormal
End With

Set xlApp = CreateObject("Excel.Application")

fileName = xlApp.GetOpenFilename("Excel Files (*.xls), *.xls")

If fileName Like "" Then
MsgBox ("Выберите файл для импортирования данных")
Else
xlApp.Workbooks.Open (fileName)

Set xlWorkbook = xlApp.ActiveWorkbook
xlApp.Visible = True

counter =  1 

For Each xlSheet In xlWorkbook.Sheets
  If xlSheet.Name Like "Диаграмма*" Then
      xlSheet.ChartArea.Copy
      PasteGraphs
    Else
     If xlSheet.ChartObjects.Count >  0  Then
       For i =  1  To xlSheet.ChartObjects.Count
         xlSheet.ChartObjects(i).Chart.ChartArea.Copy
         PasteGraphs
       Next
     End If
       
       For Each nm In xlSheet.Names
         If nm.Name Like "*таблица*" Then
          nm.RefersToRange.Copy
          PasteGraphs
         End If
       Next
       

     
   End If
Next

End If

Set xlWorkbook = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub

Sub PasteGraphs()
         
   ActivePresentation.Slides.Add(Index:=counter, Layout:=ppLayoutBlank).Select
   ActiveWindow.View.PasteSpecial ppPasteOLEObject, , , , , msoTrue
        
   ' изменение размера вставленного объекта
    With ActiveWindow.Selection.ShapeRange
        .ScaleWidth  1 . 2 , msoFalse, msoScaleFromBottomRight
        .ScaleHeight  1 . 2 , msoFalse, msoScaleFromBottomRight
        .ScaleWidth  1 . 2 , msoFalse, msoScaleFromTopLeft
        .ScaleHeight  1 . 2 , msoFalse, msoScaleFromTopLeft
    End With
    
    counter = counter +  1 

End Sub