Verknüpfung ändern Diagramm ppt VBA Makro Excel
10.10.2018 12:59:54
Pete
ich habe den untenstehenden Code (der auch funktioniert) und folgendes Problem.
Ich öffne mit dem Code eine Powerpoint in der die verknüpften Diagramme aktualisiert werden. Nun meine Frage: Wie kann ich vor der Aktualisierung den Verknüpfungspfad aller in der Powerpoint enthaltenen Diagramme auf die Excel-Datei, aus der die Powerpoint gestartet wird, ändern?
Vielen Dank vorab für eure Hilfe. Ich habe im Internet leider nix passendes gefunden bzw. war nicht in der Lage den Code zum laufen zu bringen.
Private Sub Powerpointerstellen()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Auswahl der PowerPoint Vorlage
Dim strFileToOpen As String
strFileToOpen = Application.GetOpenFilename _
(Title:="PowerPointVorlage auswählen", _
FileFilter:="PowerPoint Files *.pptx* (*.pptx*),")
'Öffnen der Powerpoint Vorlage
Dim Powerpoint As Object
Set Powerpoint = CreateObject("Powerpoint.Application")
Powerpoint.Visible = True
Powerpoint.Presentations.Open (strFileToOpen)
Dim pfad As String
Dim strFile As String
strFile = Dir(strFileToOpen)
pfad = ActiveWorkbook.Path
'Verknüpfungen aktualisieren
Powerpoint.Presentations(strFile).UpdateLinks
'Teilnehmerzahl eintragen
Powerpoint.Presentations(strFile).Slides(3).Shapes("Rectangle 55").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(1).Range("B18")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 50").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(3).Range("A20")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 47").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(3).Range("A21")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 48").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(3).Range("A22")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 49").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(4).Range("A20")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 51").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(4).Range("A21")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 52").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(4).Range("A22")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 54").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(6).Range("A20")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 55").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(6).Range("A21")
Powerpoint.Presentations(strFile).Slides(11).Shapes("Rechteck 56").TextFrame.TextRange. _
Characters.Text = ThisWorkbook.Sheets(6).Range("A22")
'ppt schließen und abspeichern
name_pp_datei = pfad & "\" & Format(Date, "YYYYMMDD") & "_" & "Auswertung_Umfrage" & ".pptx"
With Powerpoint
.ActivePresentation.SaveAs name_pp_datei
.ActivePresentation.Close
End With
Powerpoint.Quit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub