Witam, chcę napisać makro które będzie przeklejało wykresy z Excela do prezentacji PPT (jako obraz).
Niestety nie działa tak jak bym chciał. Mam problem z pętlą oraz z tym żeby każdy kolejny wykres nie jest wklejany do nowego slajdu, tylko zawsze do tego samego. Prośba o wskazanie błędów w moim kodzie:
Sub Export_PPT_E()
Dim ppApp As Object
Dim Name As Name
Dim powerpointApp As Object
Dim Slidecount As Long
Dim PPSlide As PowerPoint.Slide
Dim ChartName As String
Dim x As Integer
WB_Name = ActiveWorkbook.Name
WS_Name = ActiveSheet.Name
Application.Calculation = xlCalculationAutomatic
Set powerpointApp = CreateObject("Powerpoint.Application")
With powerpointApp
.Visible = True
.Presentations.Open Filename:="C:\Users\xxx\xxxx.pptx"
End With
x = 1
''-----------------------------------------------------------------------------------
Select Case x
Case 1
ChartName = "Chart1"
Case 2
ChartName = "Chart2"
Case 3
ChartName = "Chart3"
Case 4
ChartName = "Chart4"
Case 5
ChartName = "Chart5"
Case 6
ChartName = "Chart6"
Case 7
ChartName = "Chart7"
Case 8
ChartName = "Chart8"
Case 9
ChartName = "Chart9"
Case 10
ChartName = "Chart10"
Case 11
ChartName = "Chart11"
End Select
Do Until x = 11
'ChartName = ActiveWorkbook.Names("Chart1").Name
Application.Goto Reference:=ActiveWorkbook.Names(ChartName).Name
With Workbooks(WB_Name).Worksheets(WS_Name)
.Range(ChartName).Select
.Range(ChartName).Copy
End With
With powerpointApp
.Visible = True
Slidecount = powerpointApp.ActivePresentation.Slides.Count
If x > 1 Then Set PPSlide = powerpointApp.ActivePresentation.Slides.Add(Slidecount, ppLayoutBlank)
If Slidecount = 1 Then .ActivePresentation.Slides(.ActivePresentation.Slides().Count).Select Else .ActivePresentation.Slides(.ActivePresentation.Slides().Count - 1).Select
End With
With powerpointApp.ActiveWindow 'ActivePresentation.Slides(x)
.View.PasteSpecial DataType:=ppPasteEnhancedMetafile 'ppPasteOLEObject 'DataType:=ppPasteJPG
.Selection.ShapeRange.Left = 70.6
.Selection.ShapeRange.Top = 65.45
.Selection.ShapeRange.Width = 450
.Selection.ShapeRange.Height = 430
End With
x = x + 1
Loop
End Sub
Microsoft Excel 
Visual Basic for Applications