|
Hallo zusammen!
Mein Kommilitone und ich sind absolute Noobs und haben es mit Ach und Krach geschafft, einen (wahrscheinlich miesen) Code zu schreiben, der das macht, was wir wollen.
Er nimmt aus einer großen Excel Tabelle immer die einzelnen Zellen einer Spalte und packt die auf eine Folie eines vorgefertigten PP-Layouts. Soweit so gut. Hat auch alles geklappt, bis wir noch zwei weitere Arbeitsblätter hinzugefügt haben. Jetzt nimmt er nicht mehr alle Spalten unserer Tabelle, die wir überführen wollen ("Methodensmmlung" heißt die), sondern erzeugt nur noch 15 Folien und gibt dann einen Fehler an.
Kann uns jemand helfen und sagen, wie unser Code NUR das Arbeitsblatt "Methodensammlung" anspricht und nicht noch die anderen Arbeitsblätter mitbearbeitet?
Im Folgenden unser Code:
Public Sub Test()
Dim wb As Workbook
Dim ws As Worksheet
Dim strPlatz As String
Dim strName As String
Dim strPOTX As String
Dim strPfad As String
Dim pptVorlage As String
Dim pSlide As PowerPoint.Slide
Dim slds As PowerPoint.Slides
Dim sld As PowerPoint.Slide
Dim oLayout As CustomLayout
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As Slide
Dim ppLayout As CustomLayout
Dim i As Integer
Dim j As Integer
Dim a As Integer
Dim l As String
Dim f As String
'Dateipfad der PowerPoint Vorlage einfÙgen
strPfad = "C:\Users\User\Desktop\"
'Dateiname der PowerPoint Vorlage einfÙgen
strPOTX = "Layout-Vorlage_neu.potx"
Set pptApp = New PowerPoint.Application
pptVorlage = strPfad & strPOTX
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
Set pptPres = pptApp.ActivePresentation
Set pptLayout = pptPres.Slides(1).CustomLayout
j = 2
'Anzahl der Folien festlegen
Do While Not IsEmpty(Cells(j, 1))
Set pptSlide = pptPres.Slides.AddSlide(j, pptLayout)
j = j + 1
Loop
i = 1
'Folien ausfŸllen
Do While i < j
pptPres.Slides(i).Select
pptPres.Slides(i).Shapes("Textplatzhalter 17").TextFrame.TextRange.Characters.Text = Cells(i, 2).Value
pptPres.Slides(i).Shapes("Textplatzhalter 18").TextFrame.TextRange.Characters.Text = Cells(i, 3).Value
pptPres.Slides(i).Shapes("Textplatzhalter 1").TextFrame.TextRange.Characters.Text = Cells(i, 4).Value
pptPres.Slides(i).Shapes("Textplatzhalter 2").TextFrame.TextRange.Characters.Text = Cells(i, 5).Value
pptPres.Slides(i).Shapes("Textplatzhalter 3").TextFrame.TextRange.Characters.Text = Cells(i, 6).Value
pptPres.Slides(i).Shapes("Textplatzhalter 4").TextFrame.TextRange.Characters.Text = Cells(i, 7).Value
pptPres.Slides(i).Shapes("Textplatzhalter 7").TextFrame.TextRange.Characters.Text = Cells(i, 8).Value
pptPres.Slides(i).Shapes("Textplatzhalter 11").TextFrame.TextRange.Characters.Text = Cells(i, 9).Value
pptPres.Slides(i).Shapes("Textplatzhalter 8").TextFrame.TextRange.Characters.Text = Cells(i, 10).Value
pptPres.Slides(i).Shapes("Textplatzhalter 9").TextFrame.TextRange.Characters.Text = Cells(i, 11).Value
pptPres.Slides(i).Shapes("Textplatzhalter 5").TextFrame.TextRange.Characters.Text = Cells(i, 12).Value
pptPres.Slides(i).Shapes("Textplatzhalter 10").TextFrame.TextRange.Characters.Text = Cells(i, 19).Value
pptPres.Slides(i).Shapes("Textplatzhalter 6").TextFrame.TextRange.Characters.Text = Cells(i, 13).Value
pptPres.Slides(i).Shapes("Textplatzhalter 12").TextFrame.TextRange.Characters.Text = Cells(i, 14).Value
pptPres.Slides(i).Shapes("Textplatzhalter 13").TextFrame.TextRange.Characters.Text = Cells(i, 15).Value
pptPres.Slides(i).Shapes("Textplatzhalter 14").TextFrame.TextRange.Characters.Text = Cells(i, 16).Value
pptPres.Slides(i).Shapes("Textplatzhalter 15").TextFrame.TextRange.Characters.Text = Cells(i, 17).Value
pptPres.Slides(i).Shapes("Textplatzhalter 16").TextFrame.TextRange.Characters.Text = Cells(i, 18).Value
i = i + 1
Loop
'Speichername der neuen PowerPoint
pptPres.SaveAs strPfad & "Methodensammlung" & ".pptx"
'Schlie§t und verlŠsst die PowerPoint
pptPres.Close
pptApp.Quit
Set pptPres = Nothing
Set pptApp = Nothing
End Sub
Danke für eure Hilfe!
|