AW: VBA Code von Excel Tabelle in PowerPoint
22.08.2023 19:52:36
ralf_b
Was soll denn das für eine Beispieldatei sein?
Eigentlich hätte man dich hier so lange nachbessern lassen müssen bis die Vorlage handhabbar ist.
Die Textfelder werden dynamisch erstellt. Das kannst du gerne selbst noch anpassen.
Den Code in ein allgemeines Modul einfügen und die Excel-Datei im xlsm-Format speichern.
Der Verweis auf die Powerpointbibliothek muß im Vba-Editor gesetzt werden.
Option Explicit
Sub XLSX_to_PPTX()
'Declare Power Point variables
Dim strPOTX As String
Dim pptPfad As String
Dim pptApp As Object
Dim PPSlide As PowerPoint.Slide
Dim pptLayout As PowerPoint.CustomLayout
Dim pptPres As Presentation
Dim strPicture As String
Dim PPTShape As PowerPoint.Shape
Dim strMeasure As String
Dim strMeasure2 As String
Dim strProblem As String
Dim strProblem2 As String
Dim strProblem3 As String
Dim strAnalysis As String
Dim strResponsible As String
Dim strData As String
Dim strPfad$, pptVorlage$, i&, lrow&
strPfad = "F:\testx\" '"C:\Users\SXFOZPO\Desktop\"
strPOTX = "MyFile.potx"
Set pptApp = New PowerPoint.Application
'Opening Data from Vorlage
pptVorlage = strPfad & strPOTX
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
'Open Presentation
Set pptPres = pptApp.ActivePresentation
'Text adding PPT
'Schleife
Set pptLayout = pptPres.Slides(1).CustomLayout
lrow = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To lrow
'code for excel
strProblem = Sheets(1).Cells(i, 6).Value
strAnalysis = Sheets(1).Cells(i, 11).Value
strMeasure = Sheets(1).Cells(i, 12).Value
strResponsible = Sheets(1).Cells(i, 15).Value
strData = Sheets(1).Cells(i, 10).Value
pptPres.Slides(1).Copy
pptPres.Slides.Paste pptPres.Slides.Count + 1
With pptPres.Slides(pptPres.Slides.Count)
'Code fuer PPT Bereich
With .Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 80, 350, 25)
.Name = "Problem"
.TextFrame.TextRange.Characters.Text = strProblem
End With
With .Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 160, 350, 25)
.Name = "Problem2"
.TextFrame.TextRange.Characters.Text = strProblem
End With
With .Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 240, 350, 25)
.Name = "Problem3"
.TextFrame.TextRange.Characters.Text = strProblem
End With
With .Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 320, 350, 25)
.Name = "Analysis"
.TextFrame.TextRange.Characters.Text = strAnalysis
End With
With .Shapes.AddTextbox(msoTextOrientationHorizontal, 450, 80, 350, 25)
.Name = "Measure"
.TextFrame.TextRange.Characters.Text = strMeasure
End With
With .Shapes.AddTextbox(msoTextOrientationHorizontal, 450, 160, 350, 25)
.Name = "Measure2"
.TextFrame.TextRange.Characters.Text = strMeasure
End With
With .Shapes.AddTextbox(msoTextOrientationHorizontal, 450, 240, 350, 25)
.Name = "Responsible"
.TextFrame.TextRange.Characters.Text = strResponsible
End With
With .Shapes.AddTextbox(msoTextOrientationHorizontal, 450, 320, 350, 25)
.Name = "Data"
.TextFrame.TextRange.Characters.Text = strData
End With
End With
Next i
pptPres.Slides(1).Delete
pptPres.SaveAs Filename:="Problems_Overview"
Set pptPres = Nothing
Set pptApp = Nothing
End Sub