ich brauch dringen HILFE würde gerne mein VBA-CODE kürzen bzw. intelligenter schreiben.
Der VBA-CODE fügt Kommentare, Tabellen und Graphen in eine PowerPoint-Präsentation ein. Je PowerPoint Folie eine Tabelle (als Bild kopiert), ein Graphen und eine TextBox mit den Kommentaren.
Der Vorgang ist immer gleich. Die Einfügepositionen in PowerPoint ist auch immer gleich. Nur beinhaltet meine Excel-Datei 30 verschiedene Tabellenblätter bzw. Reiter. Dort sind die Tabellen und Kommentare an unterschiedlichen Stellen. Das ist das einzige was hier unterschiedlich ist und sich intelligent wiederholen muss.
Jetzt habe ich ein VBA-Code gebastelt, der sehr stupide ist und sehr lang, sogar zu lang um ein Modul daraus zu machen.
Kann mir da jemand Schlaues helfen?
Anbei der CODE:
Sub GenAll()
Dim pptFileName As String
'Tabelle
Dim PastePositionLeft As Integer
Dim PastePositionTop As Integer
Dim PastePositionHeight As Integer
Dim PastePositionWidth As Integer
Dim PasteTableAsDefined As Integer
'Diagramm
Dim PastePositionLeftChart As Integer
Dim PastePositionTopChart As Integer
Dim PastePositionHeightChart As Integer
Dim PastePositionWidthChart As Integer
'Einfügeposition in [cm] definieren -- Tabelle
PastePositionLeft = Application.CentimetersToPoints(14.84)
PastePositionTop = Application.CentimetersToPoints(9.68)
PastePositionHeight = Application.CentimetersToPoints(8.1)
PastePositionWidth = Application.CentimetersToPoints(17.31)
'Einfügeposition in [cm] definieren -- Diagramm
PastePositionLeftChart = Application.CentimetersToPoints(14.84)
PastePositionTopChart = Application.CentimetersToPoints(4.12)
PastePositionHeightChart = Application.CentimetersToPoints(4.51)
PastePositionWidthChart = Application.CentimetersToPoints(17.3)
'Dateiname des Templates festlegen
pptFileName = ThisWorkbook.Path & "\" & "\PPT_Template.pptx"
Dim ppApp, ppFile, ppSlide, objShape
Set ppApp = CreateObject("Powerpoint.Application")
ppApp.Visible = msoTrue
'PowerPoint konfigurieren
Set ppFile = ppApp.presentations.Open(pptFileName)
ppApp.Activate
'Textbox in PowerPoint erstellen -- FINANZEN LOKATIONEN
With ppFile.Slides(ppFile.Slides.Count).Shapes.AddShape(msoShapeRectangle, Application.CentimetersToPoints(15.57), Application.CentimetersToPoints(18.13), Application.CentimetersToPoints(4.15), Application.CentimetersToPoints(0.78)).TextFrame
.TextRange.Text = "FINANZEN " & CStr(Worksheets("GESAMT-ÜBERBLICK").Cells(11, 7).Value)
.TextRange.Font.Size = 12
.TextRange.Font.Size = 12
.TextRange.Font.Bold = False
.TextRange.Font.NameComplexScript = "CorpoS"
.TextRange.Font.NameFarEast = "CorpoS"
.TextRange.Font.Name = "CorpoS"
.TextRange.Font.Color.RGB = RGB(0, 103, 127)
.TextRange.ParagraphFormat.Alignment = msoAlignLeft
.MarginBottom = Application.CentimetersToPoints(0.13)
.MarginLeft = Application.CentimetersToPoints(0.25)
.MarginRight = Application.CentimetersToPoints(0.25)
.MarginTop = Application.CentimetersToPoints(0.13)
.VerticalAnchor = msoAnchorTop
.HorizontalAnchor = msoAnchorNone
End With
With ppFile.Slides(ppFile.Slides.Count)
.Shapes(.Shapes.Count).Line.Visible = msoFalse
.Shapes(.Shapes.Count).Fill.Visible = msoFalse
End With
DAS IST EIN BEISPIEL FÜR EIN TABELLENBLATT BZW. REITER. DIESES WIEDERHOLT SICH IMMMER NUR DURCH ANDERE ZELLENWERTE UND NAMEN.
'Excel aktivieren TABELLENBLATT -- EURO
If Worksheets("GESAMT-ÜBERBLICK").Cells(21, 18).Value (WENN GRÖßER) 0 Then
Worksheets("EURO").Activate
'Template-Folie für Detailsicht kopieren und einfügen -- Tabelle
Set ppSlide = ppFile.Slides(1)
ppSlide.Copy
ppFile.Slides(ppFile.Slides.Count).Select
ppApp.ActivePresentation.Slides.Paste(ppFile.Slides.Count + 1).Select
'zu kopierenden Bereich markieren -- Tabelle
Worksheets("EURO").Range(Cells(112, 5), Cells(140, 19)).Select
'als Bild kopieren -- Tabelle
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'in PowerPoint einfügen -- Tabelle
ppApp.ActiveWindow.Selection.sliderange.Shapes.Paste.Select
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
ppApp.ActiveWindow.Selection.ShapeRange.Left = PastePositionLeft
ppApp.ActiveWindow.Selection.ShapeRange.Top = PastePositionTop
ppApp.ActiveWindow.Selection.ShapeRange.Height = PastePositionHeight
ppApp.ActiveWindow.Selection.ShapeRange.Width = PastePositionWidth
With ppFile.Slides(ppFile.Slides.Count).Select
'zu kopierenden Bereich markieren -- Diagramm
ActiveSheet.ChartObjects("EUROChart").Activate
ActiveChart.ChartArea.Copy
ActiveChart.ChartArea.Select
With ppApp.ActiveWindow.Selection.ShapeRange
'in PowerPoint einfügen -- Diagramm
ppApp.ActiveWindow.Selection.sliderange.Shapes.Paste.Select
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
ppApp.ActiveWindow.Selection.ShapeRange.Left = PastePositionLeftChart
ppApp.ActiveWindow.Selection.ShapeRange.Top = PastePositionTopChart
ppApp.ActiveWindow.Selection.ShapeRange.Height = PastePositionHeightChart
ppApp.ActiveWindow.Selection.ShapeRange.Width = PastePositionWidthChart
End With
End With
'Textbox in PowerPoint erstellen -- Workpackage Content
With ppFile.Slides(ppFile.Slides.Count).Shapes.AddShape(msoShapeRectangle, Application.CentimetersToPoints(1.94), Application.CentimetersToPoints(4.48), Application.CentimetersToPoints(12.4), Application.CentimetersToPoints(13.25)).TextFrame
.TextRange.Text = CStr(Cells(4, 2).Value) & vbCr & vbCr & CStr(Cells(5, 2).Value) & vbCr & vbCr & CStr(Cells(6, 2).Value) & vbCr & vbCr & CStr(Cells(7, 2).Value) & vbCr & vbCr & CStr(Cells(8, 2).Value) & vbCr & vbCr & CStr(Cells(9, 2).Value) & vbCr & vbCr & CStr(Cells(10, 2).Value) & vbCr & vbCr & CStr(Cells(11, 2).Value) & vbCr & vbCr & CStr(Cells(12, 2).Value)
.TextRange.Font.Size = 12
.TextRange.Font.NameComplexScript = "CorpoS"
.TextRange.Font.NameFarEast = "CorpoS"
.TextRange.Font.Name = "CorpoS"
.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextRange.ParagraphFormat.Alignment = msoAlignLeft
.MarginBottom = Application.CentimetersToPoints(0)
.MarginLeft = Application.CentimetersToPoints(0)
.MarginRight = Application.CentimetersToPoints(0)
.MarginTop = Application.CentimetersToPoints(0)
.VerticalAnchor = msoAnchorTop
.HorizontalAnchor = msoAnchorNone
End With
With ppFile.Slides(ppFile.Slides.Count)
.Shapes(.Shapes.Count).Line.Visible = msoFalse
.Shapes(.Shapes.Count).Fill.Visible = msoFalse
End With
'Textbox in PowerPoint erstellen -- FINANZ Name
With ppFile.Slides(ppFile.Slides.Count).Shapes.AddShape(msoShapeRectangle, Application.CentimetersToPoints(1.75), Application.CentimetersToPoints(0.8), Application.CentimetersToPoints(30.38), Application.CentimetersToPoints(3.2)).TextFrame
.TextRange.Text = CStr(Worksheets("GESAMT-ÜBERBLICK").Cells(62, 5).Value)
.TextRange.Font.Size = 35
.TextRange.Font.NameComplexScript = "CorpoS"
.TextRange.Font.NameFarEast = "CorpoS"
.TextRange.Font.Name = "CorpoS"
.TextRange.Font.Color.RGB = RGB(0, 0, 0)
.TextRange.ParagraphFormat.Alignment = msoAlignLeft
.MarginBottom = 0
.MarginLeft = 0
.MarginRight = 0
.MarginTop = 0
.VerticalAnchor = msoAnchorTop
.HorizontalAnchor = msoAnchorNone
End With
With ppFile.Slides(ppFile.Slides.Count)
.Shapes(.Shapes.Count).Line.Visible = msoFalse
.Shapes(.Shapes.Count).Fill.Visible = msoFalse
End With
End If