Dim ws As Worksheet
Dim gruppen As Object
Dim gruppen_name As Variant
Dim ws_list As Object
Set gruppen = CreateObject("Scripting.Dictionary")
For Each ws In ActiveWorkbook.Sheets
If Trim(CStr(ws.Range("A1").Value)) = "X" Then
gruppen_name = Trim(CStr(ws.Range("C2").Value))
If gruppen_name <> "" Then
If Not gruppen.Exists(gruppen_name) Then
Set ws_list = CreateObject("System.Collections.ArrayList")
gruppen.Add gruppen_name, ws_list
Else
Set ws_list = gruppen(gruppen_name)
End If
ws_list.Add ws.Name
End If
End If
Next ws
For Each gruppen_name In gruppen.Keys
Call export_gruppe_fix4(gruppen(gruppen_name), gruppen_name)
Next gruppen_name
MsgBox "Gruppenexport abgeschlossen!"
End Sub
Sub export_gruppe_fix4(ws_names As Variant, gruppen_name As Variant)
Dim PowerPointApp As Object
Dim pres As Object
Dim i As Integer
Dim ws_exp As Worksheet
Dim export_range As Range
Dim copy_format As String
Dim blend_rows As String
Dim j As Integer
Dim TEMPLATE_PATH As String
Dim savePath As String
Dim usedSlides As Integer
Dim shp As Object
Dim tableShape As Object
TEMPLATE_PATH = "Template"
Set PowerPointApp = CreateObject("PowerPoint.Application")
PowerPointApp.Visible = True
Set pres = PowerPointApp.Presentations.Open(TEMPLATE_PATH)
Set ws_exp = ThisWorkbook.Sheets(ws_names(0))
savePath = ws_exp.Range("J3").Value & ws_exp.Range("G3").Value & " " & Format(Date, "dd.MM.yyyy") & ".pptx"
usedSlides = WorksheetFunction.Min(ws_names.Count, 4)
For i = 0 To usedSlides - 1
Set ws_exp = ThisWorkbook.Sheets(ws_names(i))
With ws_exp
blend_rows = ""
Set export_range = .Range(.Range("C5").Value)
copy_format = Trim(LCase(.Range("G5").Value))
pres.Slides(i + 1).Shapes("TITEL").TextFrame.TextRange.Text = .Range("A3")
If copy_format = "tabelle" Or copy_format = "bild" Then
For j = 10 To 50
If .Cells(j, 1) = "" Then
If blend_rows = "" Then
blend_rows = j & ":" & j
Else
blend_rows = blend_rows & "," & j & ":" & j
End If
End If
Next j
If blend_rows <> "" Then
.Range(blend_rows).EntireRow.Hidden = True
End If
End If
' Einfügen und Referenz auf das neue Shape setzen
If copy_format = "tabelle" Then
export_range.Copy
pres.Slides(i + 1).Shapes.Paste
Set shp = pres.Slides(i + 1).Shapes(pres.Slides(i + 1).Shapes.Count)
ElseIf copy_format = "bild" Then
export_range.CopyPicture
pres.Slides(i + 1).Shapes.PasteSpecial DataType:=2
Set shp = pres.Slides(i + 1).Shapes(pres.Slides(i + 1).Shapes.Count)
End If
.Range(.Cells(10, 1), .Cells(50, 1)).EntireRow.Hidden = False
' Auf TABLE-Shape ausrichten
Set tableShape = Nothing
On Error Resume Next
Set tableShape = pres.Slides(i + 1).Shapes("TABLE")
On Error GoTo 0
If Not tableShape Is Nothing And Not shp Is Nothing Then
shp.Top = tableShape.Top
shp.Left = tableShape.Left
shp.Width = tableShape.Width
tableShape.Visible = False
End If
If .Range("J5") <> "" Then
pres.Slides(i + 1).InsertFromFile .Range("J5"), 0
End If
If .Range("H5") <> "" Then
pres.Slides(i + 1).InsertFromFile .Range("H5"), pres.Slides(i + 1).Shapes.Count
End If
End With
Next i
' Leere Slides am Ende löschen
For i = pres.Slides.Count To usedSlides + 1 Step -1
pres.Slides(i).Delete
Next i
pres.SaveAs savePath
' Präsentation bleibt offen
End Sub
Sub aktualisieren()
ActiveWorkbook.RefreshAll
End Sub
Vielen Dank euch schonmal