Hallo mal wieder,
mit folgendem Code öffne ich aus einer Excel-Datei mit ca. 25 Sheets eine vorhandene PowerPoint-Vorlage und kopiere die jeweilige Tabelle rüber (siehe auch Beitrag http://www.wer-weiss-was.de/app/service/board_navi?A…):
Function SelectArea() As String
Dim Internrange As Range
Dim rngBereich
Dim Rletzte, Cletzte As Long
On Error GoTo Brutt
Set Sourcebok = ActiveWorkbook
Rletzte = Range("A65536").End(xlUp).Row
Cletzte = Range("IV1").End(xlToLeft).Column
Set rngBereich = Range(Cells(1, 1), Cells(Rletzte, Cletzte + 1))
SelectArea = rngBereich.Address
Exit Function
Brutt:
SelectArea = "A1"
End Function
Function sShortname(ByVal Orrginal As String) As String
Dim iii As Long
sShortname = ""
For iii = 1 To Len(Orrginal)
If Mid(Orrginal, iii, 1) " " Then \_
sShortname = sShortname & Mid(Orrginal, iii, 1)
Next
End Function
Function fctVerzeichnisExists(oname) As Boolean
On Error GoTo Fehler
ChDir oname
fctVerzeichnisExists = True
Exit Function
Fehler:
fctVerzeichnisExists = False
End Function
Public Sub Alle\_Bilder\_ppt()
Dim varReturn As Variant
Dim MyAddress As String
Dim SaveName As Variant
Dim MySuggest As String
Dim oname As String
Dim Hi As Long
Dim Wi As Long
Dim Suffiks As Long
Dim Tagdat, tach, mon, ja As String
Dim Tabellen As Integer
Dim appPP As Object, Slide As Object
For Tabellen = 1 To Worksheets.Count 'Schleife über Tabellenblätter
Set Sourcebok = ActiveWorkbook
Worksheets(Tabellen).Activate
MySuggest = sShortname(ActiveSheet.Name)
Sourcebok.Activate
MyAddress = SelectArea
If MyAddress "A1" Then
Tagdat = Format(Date, "yyyy-mm-dd")
oname = "C:\Eigene\_Dateien\_Lokal\PPts\" & Tagdat
If Not fctVerzeichnisExists(oname) Then
MkDir oname
Else
End If
SaveName = oname & "\" & MySuggest \_
& ".ppt"
Range(MyAddress).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set appPP = CreateObject("PowerPoint.Application")
With appPP
.Visible = True
.Presentations.Open Filename:="C:\Eigene\_Dateien\_Lokal\Leere-Vorlage.ppt", ReadOnly:=msoFalse
.ActivePresentation.Slides.Add 1, ppLayoutBlank
Set Slide = .ActivePresentation.Slides(1)
Slide.Shapes.Paste
With Slide.Shapes(1)
.Left = 30
.Top = 130
End With
End With
If SaveName = False Then
GoTo Avbryt
End If
With appPP
.Visible = msoTrue
.ActivePresentation.SaveAs (SaveName)
.ActivePresentation.Close
.Quit
End With
Sourcebok.Activate
End If
Avbryt:
On Error Resume Next
Application.StatusBar = False
Next Tabellen 'nächstes Worksheet
End Sub
Das alles klappt auch wunderbar beim ersten Mal, beim zweiten Sheet ist Powerpoint noch geöffnet und er führt alles brav aus bis zu der Stelle:
Slide.Shapes.Paste
With Slide.Shapes(1)
Dort schließt er mir komischerweise PPT und kann logischerweise die .ppt nicht mehr abspeichern. Sieht einer von Euch den Fehler?
Viele Grüße und danke für Eure Hilfe!
Tina
) Hatte den Link aus meiner eigenen Artikelliste kopiert und da zeigt er mir ja schon immer den aktuellen an?!