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