MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft PowerPoint
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 26.06.2019, 12:07   #1
HilfeProblem
MOF User
MOF User
Standard VBA - VBA - Per Excel VBA ausgewählte PPTs zusammenfügen

Hallo zusammen,

ich muss nach längerer Zeit mal wieder ein Makro schreiben und bin seit mehreren Tagen am Krübeln . Komme aber leider auf keinen Lösungsansatz. Auch nicht mit Hilfe des www.

Vllt. hat ja hier einer eine gute Idee.

Problemstellung:
Ich habe 5 einzelne PPTs (hängen an). In einer Excel (hängt an) gibt es die Möglichkeit auszuwählen, welche der PPTs gezeigt werden sollen.
In dem Beispielfall sollen die folgenden gezeigt werden:
- 1.0_Cover.pptx
- 4.0_Katze.pptx

Mein Ziel ist es, diese 2 PPTs nun automatisch per VBA zusammen zu führen.

Gibt es hierfür eine Möglichkeit?

Ich bedanke mich schon einmal im Voraus.
Gruß
Michael
Angehängte Dateien
Dateityp: xlsm PPT_zusammen_stellen.xlsm (17,0 KB, 0x aufgerufen)
Dateityp: pptx 1.0_Cover.pptx (32,0 KB, 0x aufgerufen)
Dateityp: pptx 2.0_Inhaltsverzeichnis.pptx (32,8 KB, 0x aufgerufen)
Dateityp: pptx 3.0_Hund.pptx (31,9 KB, 0x aufgerufen)
Dateityp: pptx 4.0_Katze.pptx (31,9 KB, 0x aufgerufen)
HilfeProblem ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 26.06.2019, 13:34   #2
derHoepp
MOF User
MOF User
Standard

Hallo Michael,

prinzipiell funktioniert das so:
Code:

Option Explicit

Sub testen()
    Dim filenames As Variant
    Dim TargetPresentation As Presentation
    Set TargetPresentation = ActivePresentation

    filenames = Array("C:\Daten\1.pptx", "C:\Daten\3.pptx")
    Dim i As Long
    For i = LBound(filenames) To UBound(filenames)
        With Presentations.Open(filenames(i))
            .Slides.Range.Copy
            TargetPresentation.Slides.Paste
            .Close
        End With
    Next i
End Sub
Für das Steuern aus Excel heraus müsstest du noch eine eigene Application-Instanz nutzen und dich nicht auf ActivePresentation beziehen, sondern eine konkrete, neue Presentation erstellen.

Kommst du damit schon klar?
Viele Grüße
derHöpp
derHoepp ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 28.06.2019, 11:24   #3
HilfeProblem
Threadstarter Threadstarter
MOF User
MOF User
Standard

Vielen Dank @ derHöpp.

Habe dein Makro in ppt. eingesetzt und es macht genau das was ich brauche. Super!!!!

Ich habe die letzte zwei Tage noch ausgiebig probiert und bin dabei auf den folgenden Code gekommen. Welchen ich ins XLS-Makro implementiert habe.

Code:
Sub PptZusammenFuegen()

'Definieren der Dateipfade zu dein einzelnen Präsentationen, wenn sie eingebaut werden sollen
If Worksheets("Tabelle1").Range("C3") = "Ja" Then
Cover = "C:1.0_Cover.pptx"
Else
Cover = ""
End If

If Worksheets("Tabelle1").Range("C4") = "Ja" Then
Inhaltsverzeichnis = "C:2.0_Inhaltsverzeichnis.pptx"
Else
Inhaltsverzeichnis = ""
End If

If Worksheets("Tabelle1").Range("C5") = "Ja" Then
Hund = "C:3.0_Hund.pptx"
Else
Hund = ""
End If

If Worksheets("Tabelle1").Range("C6") = "Ja" Then
Katze = "C:4.0_Katze.pptx"
Else
Katze = ""
End If


'Öffnen der PPT-Vorlage
Dim ppApp As Object
Dim ppFile As Object
Dim ppPres As String

'Dateiname
ppPres = Worksheets("Tabelle1").Range("G2")
'Object referenzieren
Set ppApp = CreateObject("Powerpoint.Application")

'Object initialisieren
ppApp.Visible = msoTrue
'PPT öffnen
Set ppFile = ppApp.Presentations.Open(ppPres)

'BIS HIER HIN LÄUFTS
Dim filenames As Variant
'Dim TargetPresentation As Presentation
'Set TargetPresentation = ActivePresentation


filenames = Array(Cover, Inhaltsverzeichnis, Hund, Katze)
Dim i As Long
For i = LBound(filenames) To UBound(filenames)
With ppFile.Open(filenames(i))
.Slides.Range.Copy
ppFile.Slides.Paste
.Close
End With
Next i

End Sub
________________

Ich lese im ersten Teil quasi aus, welche ppts zusammengefügt werden sollen.
Im zweiten (deinem) Teil soll dann die ppt zusammen gefügt werden.

Sehe ich es richtig, das dein Teil im ppt-Makro laufen muss, da es nicht mit dem xls-makro kompatibel ist.
Also geht es nur so, dass ich dass ppt-makro mittels Befehl im Excel-Makro starten lasse?

Danke schon mal.
HilfeProblem ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 02.07.2019, 13:51   #4
HilfeProblem
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo zusammen,

ich habe jetzt einfunktionierende Lösung gefunden.

Ich kann in der Excel auswählen, welche einzelnen PPTs ich zusammenfügen möchte.
Über das Makro in Excel wird die PPT Vorlage geöffnet und das PPT-Makro automatisch gestartet.
Das PPT-Makro fragt in der Excel ab, welche Präsentationen zusammengefügt werden sollen.

Hier der Code des Excel-Makros:

Sub PptZusammenFuegen()

'Öffnen der Basis Powerpoint

Dim powerpointObj As Object
Dim PowPres As Object

Set powerpointObj = CreateObject("powerpoint.application")
powerpointObj.Visible = True
Set PowPres = powerpointObj.Presentations.Open("LINK zur Vorlage")

'Starten des Makros in Powerpoint
powerpointObj.Run "Test_zusammenführen!Modul1.testen"

End Sub

_______________________________

Und hier das PPT-Makro:
Sub testen()
Dim filenames As Variant
Dim TargetPresentation As Presentation
Set TargetPresentation = ActivePresentation


Dim Excel As Object

Dim Pfad, Name, Blatt As String

Set Excel = GetObject(, "Excel.Application")

'Der Link zur jeweiligen Präsentation muss in der Excel hinterlegt sein. In meinem Fall in Spalte D.
Cover = Excel.ActiveWorkbook.Worksheets("Tabelle1").Range("D3")
Inhaltsverzeichnis = Excel.ActiveWorkbook.Worksheets("Tabelle1").Range("D4")
Hund = Excel.ActiveWorkbook.Worksheets("Tabelle1").Range("D5")
Katze = Excel.ActiveWorkbook.Worksheets("Tabelle1").Range("D6")

Name = Excel.ActiveWorkbook.Name

Blatt = Excel.ActiveWorkbook.ActiveSheet.Name


filenames = Array(Cover, Inhaltsverzeichnis, Hund, Katze)
Dim i As Long

For i = LBound(filenames) To UBound(filenames)

'Wenn eine einzelne PPT nicht eingefügt werden soll, dann zeigt der Platzhalter "". Das würde einen Fehler beim Öffnen ausgeben. Daher hier OnErrorGoTo
On Error GoTo NaechstesI

With Presentations.Open(filenames(i))
.Slides.Range.Copy
TargetPresentation.Slides.Paste
.Close
End With

neubeginnen:
Next
Exit Sub

NaechstesI:
Resume neubeginnen

End Sub
_______________________________

Bei Fragen gerne melden.
HilfeProblem ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 02.07.2019, 16:31   #5
derHoepp
MOF User
MOF User
Standard

Hallo Michael,

sorry, ich hatte noch keine Zeit, mich weiter mit deinem Problem zu beschäftigen. Du könntest es mir allerdings auch etwas einfacher machen und deinen Code in Code-Tags posten, dann macht es mehr Spaß, ihn zu lesen. Aus der Powerpointdatei mit Application.Run jedoch ein eigenes Makro aufzurufen scheint mir am wenigsten sinnvoll. Ich glaube, dein eigentliches Problem liegt darin, dass du nicht weißt, wie du aus den Zellen C4 bis C6 ein Array erzeugst, dass nur die benötigten Daten beinhaltet.

Viele Grüße erstmal!
derHöpp
derHoepp ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 03.07.2019, 08:10   #6
HilfeProblem
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hey der Höpp,

sorry, habe erst jetzt gesehen, wie das mit den Codes funktioniert.

Hier der Code des Excel-Makros:
Code:

Sub PptZusammenFuegen()

'Öffnen der Basis Powerpoint

Dim powerpointObj As Object
Dim PowPres As Object

Set powerpointObj = CreateObject("powerpoint.application")
powerpointObj.Visible = True
Set PowPres = powerpointObj.Presentations.Open("LINK zur Vorlage")

'Starten des Makros in Powerpoint
powerpointObj.Run "Test_zusammenführen!Modul1.testen"

End Sub
Und hier das PPT-Makro:
Code:

Sub testen()
Dim filenames As Variant
Dim TargetPresentation As Presentation
Set TargetPresentation = ActivePresentation


Dim Excel As Object

Dim Pfad, Name, Blatt As String

Set Excel = GetObject(, "Excel.Application")

'Der Link zur jeweiligen Präsentation muss in der Excel hinterlegt sein. In meinem Fall in Spalte D.
Cover = Excel.ActiveWorkbook.Worksheets("Tabelle1").Range("D3")
Inhaltsverzeichnis = Excel.ActiveWorkbook.Worksheets("Tabelle1").Range("D4")
Hund = Excel.ActiveWorkbook.Worksheets("Tabelle1").Range("D5")
Katze = Excel.ActiveWorkbook.Worksheets("Tabelle1").Range("D6")

Name = Excel.ActiveWorkbook.Name

Blatt = Excel.ActiveWorkbook.ActiveSheet.Name


filenames = Array(Cover, Inhaltsverzeichnis, Hund, Katze)
Dim i As Long

For i = LBound(filenames) To UBound(filenames)

'Wenn eine einzelne PPT nicht eingefügt werden soll, dann zeigt der Platzhalter "". Das würde einen Fehler beim Öffnen ausgeben. Daher hier OnErrorGoTo 
On Error GoTo NaechstesI

With Presentations.Open(filenames(i))
.Slides.Range.Copy
TargetPresentation.Slides.Paste
.Close
End With

neubeginnen:
Next
Exit Sub

NaechstesI:
Resume neubeginnen

End Sub

Ich glaube auch das die Lösung nicht optimal ist. Bin auch absolut kein Profi ;-).
Aber im Endeffekt machen die beiden Makro's genau das was ich will.
Bis auf die Problematik, dass beim kopieren der PPT-Folien die Formatierung verloren geht. (habe dafür einen anderen Thread aufgemacht).
HilfeProblem ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 03.07.2019, 08:54   #7
derHoepp
MOF User
MOF User
Standard

Moin,

ich wäre beim ersten Code geblieben. Und natürlich sollst du Code mit Einrückungen hier hochladen. Ich hab das mal für deinen ersten Versuch getan:
Code:

Option Explicit

Sub PptZusammenFuegen()
    'Definieren der Dateipfade zu dein einzelnen Präsentationen, wenn sie eingebaut werden sollen
    If Worksheets("Tabelle1").Range("C3") = "Ja" Then
        Cover = "C:1.0_Cover.pptx"
    Else
        Cover = ""
    End If
    
    If Worksheets("Tabelle1").Range("C4") = "Ja" Then
        Inhaltsverzeichnis = "C:2.0_Inhaltsverzeichnis.pptx"
    Else
        Inhaltsverzeichnis = ""
    End If
    
    If Worksheets("Tabelle1").Range("C5") = "Ja" Then
        Hund = "C:3.0_Hund.pptx"
    Else
        Hund = ""
    End If
    
    If Worksheets("Tabelle1").Range("C6") = "Ja" Then
        Katze = "C:4.0_Katze.pptx"
    Else
        Katze = ""
    End If
    
    
    'Öffnen der PPT-Vorlage
    Dim ppApp As Object
    Dim ppFile As Object
    Dim ppPres As String
    
    'Dateiname
    ppPres = Worksheets("Tabelle1").Range("G2")
    'Object referenzieren
    Set ppApp = CreateObject("Powerpoint.Application")
    
    'Object initialisieren
    ppApp.Visible = msoTrue
    'PPT öffnen
    Set ppFile = ppApp.Presentations.Open(ppPres)
    
    'BIS HIER HIN LÄUFTS
    Dim filenames As Variant
    'Dim TargetPresentation As Presentation
    'Set TargetPresentation = ActivePresentation
    
    
    filenames = Array(Cover, Inhaltsverzeichnis, Hund, Katze)
    Dim i As Long
    For i = LBound(filenames) To UBound(filenames)
       With ppFile.Open(filenames(i))
            .Slides.Range.Copy
            ppFile.Slides.Paste
            .Close
        End With
    Next i
End Sub
Problematisch daran ist erstens, wie du dein Array erzeugst und zweitens der Teil, in dem du die einzelnen Dateien öffnest. Du öffnest diese mit der Open-Methode von ppFile. ppFile ist aber ein Presentation-Objekt. Ein Presentation-Objekt hat keine .Open-Methode, dafür brauchst du ein Application-Objekt.

Long Story Short, ungetestet sollte es so funktionieren:
Code:

Option Explicit


Sub PptZusammenFuegen2()
    Dim FileNamesString As String
    'Definieren der Dateipfade zu dein einzelnen Präsentationen, wenn sie eingebaut werden sollen
    'Der Aufbau deines Arrays war nicht ganz in ordnung.
    If Worksheets("Tabelle1").Range("C3") = "Ja" Then FileNamesString = FileNamesString & "C:1.0_Cover.pptx;"
    If Worksheets("Tabelle1").Range("C4") = "Ja" Then FileNamesString = FileNamesString & "C:2.0_Inhaltsverzeichnis.pptx;"
    If Worksheets("Tabelle1").Range("C5") = "Ja" Then FileNamesString = FileNamesString & "C:3.0_Hund.pptx;"
    If Worksheets("Tabelle1").Range("C6") = "Ja" Then FileNamesString = FileNamesString & "C:4.0_Katze.pptx;"
    
    Dim FileNameArray As Variant
    FileNameArray = Split(Left(FileNamesString, Len(FileNamesString) - 1), ";")
    
    'Öffnen der PPT-Vorlage
    Dim ppApp As Object
    Dim ppTarget As Object
    Dim ppPresName As String
    
    'Dateiname
    ppPresName = Worksheets("Tabelle1").Range("G2")
    'Object referenzieren
    Set ppApp = CreateObject("Powerpoint.Application")
    
    'Object initialisieren
    ppApp.Visible = msoTrue
    'PPT öffnen
    Set ppTarget = ppApp.Presentations.Open(ppPresName)
    
    'BIS HIER HIN LÄUFTS
    Dim i As Long
    For i = LBound(FileNameArray) To UBound(FileNameArray)
       With ppApp.Presentations.Open(FileNameArray(i)) 'Die Open-Methode ist Teil von Application und Presentations-Collection
            .Slides.Range.Copy
            ppTarget.Slides.Paste
            .Close
        End With
    Next i
End Sub
Für die Arrayerstellung gibt es sicherlich noch bessere Möglichkeiten, als hart-codierte Pfade, aber ich kenne deinen Dateiaufbau nicht genug.

Viele Grüße
derHöpp
derHoepp ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 06:41 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.