MyTetra Share
Делитесь знаниями!
Макрос для переноса диаграм и таблиц из execl в powerpoint
Время создания: 01.02.2020 00:37
Текстовые метки: vba_powerpoint, slides
Раздел: !Закладки - VBA - PowerPoint
Запись: xintrea/mytetra_db_adgaver_new/master/base/1580506650lba6nemi1z/text.html на raw.githubusercontent.com
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
Так же в этом разделе:
 
MyTetra Share v.0.58
Яндекс индекс цитирования