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.Panes(2).Activate
ActiveWindow.View.PasteSpecial ppPasteOLEObject, , , , , msoTrue
'
' изменение размера вставляемого объекта

With ActiveWindow.Selection.ShapeRange
.ScaleWidth 1.1, msoFalse, msoScaleFromBottomRight
.ScaleHeight 1.1, msoFalse, msoScaleFromBottomRight
.ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
.ScaleHeight 1.1, msoFalse, msoScaleFromTopLeft
End With
counter = counter + 1
End Sub