Option Explicit
Dim ppApp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppSlide As PowerPoint.Slide
Public Sub ClearClipboard()
Sheets("Test").Range("X40").Copy
Application.CutCopyMode = False
End Sub
Private Sub Zeichne_Tabelle(ppApp As Object, anfang As String, ende As String, top As Integer, _
left As Integer, seite As Integer)
Set ppSlide = ppPres.Slides(1)
Sheets("Test").Activate
Sheets("Test").Range(anfang + ":" + ende).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ppApp.Visible = msoTrue
ppApp.ActiveWindow.View.GotoSlide 1
ppSlide.Shapes.Paste.Select
Call DieseArbeitsmappe.ClearClipboard
ppApp.Visible = msoTrue
With ppApp.ActiveWindow.Selection.ShapeRange
.top = top
.left = left
.Width = .Width
.Height = .Height * 1.25
End With
Set ppSlide = Nothing
End Sub
Sub ExcelNachPptClick()
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
Set ws = Sheets("Test")
Set ppApp = CreateObject("Powerpoint.Application")
Set ppPres = ppApp.Presentations.Add
For i = 1 To 300
ppApp.Visible = msoTrue
ppPres.Slides.Add 1, ppLayoutBlank
ppPres.Slides(1).Select
ppApp.Visible = msoTrue
ppApp.ActiveWindow.View.GotoSlide 1
j = i + 4
Call Zeichne_Tabelle(ppApp, "A" & i, "D" & j, 100, 100, i)
Call Zeichne_Tabelle(ppApp, "A" & i, "D" & j, 200, 100, i)
Call Zeichne_Tabelle(ppApp, "A" & i, "D" & j, 300, 100, i)
Next i
Set ppApp = Nothing
Set ppPres = Nothing
End Sub