Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: ExcelRange to PowerPoint-Slide

VBA: ExcelRange to PowerPoint-Slide
16.02.2020 16:56:11
Tobias
Hallo zusammen,
mein Vorhaben ist wie folgt:
ich möchte die Daten des Worksheets ws_Output für jeden Monat, Jahr (Spalte 1) in diesem Worksheet in eine neue PowerPoint-Slide pasten. Die Daten zum Pasten sind von Spalte 1-6 (A-F). Das Ganze soll also in einer Schleife geschehen. Für jede Slide sollen auch die Spaltenüberschriften, d.h. Zeile 1 beibehalten werden, weshalb ich mir die Ranges über Union zusammensetze. Beim Debuggen des Selects von der Variable rngComplete passt soweit alles, jedoch wird in der ersten Slide nur die Daten vom ersten Wert in Spalte 1 gepastet, in der nächsten Slide jedoch die Daten vom ersten und zweiten Wert gepastet etc. das heißt es passt etwas nicht, obwohl ich die Ranges update. Bin über eure Hilfe dankbar. Scheinbar muss ich den Range zurücksetzen nach jedem Durchlauf.
Vielen Dank und freundliche Grüße
Hier mein bisheriger Code:
Sub ExcelRangeToPowerPoint()
Dim rngComplete As Range
Dim rangeHeader As Range
Dim rangeData As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim startrowToCopy As Long
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint. _
Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Set Variable monthYearValue as cellvalue "A2"
Modul3.monthYearValue = Modul3.ws_Output.Range("A2").Text
'Set Variable startrowtoCopy = 2 -> first row with values
startrowToCopy = 2
'Loop through Month-Year-Column (only the filtered rows)
For i = 2 To Modul3.lastrowWorksheetOutput
If Modul3.monthYearValue  Modul3.ws_Output.Range("A" & i).Value Then
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
'Set ranges
Set rangeHeader = Modul3.ws_Output.Range("A1:F1")
Set rangeData = Modul3.ws_Output.Range("A" & startrowToCopy & ":F" & (i - 1))
Set rngComplete = Union(rangeHeader, rangeData)
rngComplete.Select
Selection.Copy
'Copy Excel Range
'rngComplete.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2  '6 = Paste as PNG
Set myShape = mySlide.Shapes(mySlide.Shapes.count)
myPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = "VMI Consumption Data  _
for " & Modul3.monthYearValue
With myShape
myShape.Width = 400
myShape.Height = 300
'higher Left -> more right direction moving
myShape.Left = 150
'higher Top -> more bottom direction moving
myShape.Top = 130
Modul3.monthYearValue = Modul3.ws_Output.Range("A" & i).Text
End With
startrowToCopy = i
End If
Next i
'Make PowerPoint Visible and Active and FullScreen
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.DisplayFullScreen = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Doppelt oT
16.02.2020 17:01:06
Tobias
Hallo,
das sind unterschiedliche Fehler, wäre dankbar, wenn nicht wahllos Beiträge als doppelt markiert würden. Es sind wie gesagt wirklich unterschiedliche Beiträge.
Vielen Dank und Grüße
AW: VBA: ExcelRange to PowerPoint-Slide
16.02.2020 17:35:44
Nepumuk
Hallo Tobias,
ich bin jetzt mal davon ausgegangen dass sich in Spalte A echte Datümer befinden:
Option Explicit

Sub ExcelRangeToPowerPoint()
    
    Dim rngComplete As Range
    Dim rangeHeader As Range
    Dim rangeData As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    Dim startrowToCopy As Long
    Dim i As Long
    Dim objDictionary As Object
    Dim avntValues As Variant, vntItem As Variant
    Dim strDate As String
    
    
    'Create an Instance of PowerPoint
    On Error Resume Next
    
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
    
    'Clear the error between errors
    Err.Clear
    
    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then _
        Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
    If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    
    On Error GoTo 0
    
    With Modul3.ws_Output
        avntValues = .Range(.Cells(2, 1), .Cells(Modul3.lastrowWorksheetOutput, 1)).Value
    End With
    
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    
    With objDictionary
        For Each vntItem In avntValues
            .Item(Key:=DateSerial(Year(vntItem), Month(vntItem), 1)) = vbNullString
        Next
    End With
    
    'Create a New Presentation
    Set myPresentation = PowerPointApp.Presentations.Add
    
    'Loop through Month-Year-Column (only the filtered rows)
    For Each vntItem In objDictionary.keys
        
        Modul3.monthYearValue = vntItem
        
        'Add a slide to the Presentation
        Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
        'Set ranges
        
        strDate = Replace$(Format$(vntItem, "m.d.yyyy"), ".", "/")
        
        Call Modul3.ws_Output.Rows(1).AutoFilter(Field:=1, Operator:= _
            xlFilterValues, Criteria2:=Array(1, strDate))
        
        Call Modul3.ws_Output.AutoFilter.Range.Copy
        
        DoEvents
        DoEvents
        
        'Paste to PowerPoint and position
        mySlide.Shapes.PasteSpecial DataType:=2 '6 = Paste as PNG
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
        
        myPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = _
            "VMI Consumption Data for " & Modul3.monthYearValue
        
        With myShape
            myShape.Width = 400
            myShape.Height = 300
            'higher Left -> more right direction moving
            myShape.Left = 150
            'higher Top -> more bottom direction moving
            myShape.Top = 130
            
        End With
        
    Next
    
    Call Modul3.ws_Output.ShowAllData
    
    
    'Make PowerPoint Visible and Active and FullScreen
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    ' Application.DisplayFullScreen = True
    
    'Clear The Clipboard
    Application.CutCopyMode = False
    
    Set objDictionary = Nothing
    Set myShape = Nothing
    Set mySlide = Nothing
    Set myPresentation = Nothing
    Set PowerPointApp = Nothing
    
End Sub

Gruß
Nepumuk
Anzeige
AW: VBA: ExcelRange to PowerPoint-Slide
16.02.2020 17:47:04
Tobias
Hallo Nepumuk,
vielen Dank für deine Mühe. Es sind keine echten Datümer, sondern als Text-Format in Spalte A eingespeichert, wie folgt mm.yyyy. Wenn du das abändern kannst, wäre es super. Werd es mir sonst selbst anschauen, wie ich es anpassen kann.
Vielen Dank und Gruß
Tobias
AW: VBA: ExcelRange to PowerPoint-Slide
16.02.2020 17:59:41
Nepumuk
Hallo Tobias,
teste mal:
Option Explicit

Sub ExcelRangeToPowerPoint()
    
    Dim rngComplete As Range
    Dim rangeHeader As Range
    Dim rangeData As Range
    Dim PowerPointApp As Object
    Dim myPresentation As Object
    Dim mySlide As Object
    Dim myShape As Object
    Dim startrowToCopy As Long
    Dim i As Long
    Dim objDictionary As Object
    Dim avntValues As Variant, vntItem As Variant
    Dim strDate As String
    
    
    'Create an Instance of PowerPoint
    On Error Resume Next
    
    'Is PowerPoint already opened?
    Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
    
    'Clear the error between errors
    Err.Clear
    
    'If PowerPoint is not already open then open PowerPoint
    If PowerPointApp Is Nothing Then _
        Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
    
    'Handle if the PowerPoint Application is not found
    If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
    End If
    
    On Error GoTo 0
    
    With Modul3.ws_Output
        avntValues = .Range(.Cells(2, 1), .Cells(Modul3.lastrowWorksheetOutput, 1)).Value
    End With
    
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    
    With objDictionary
        For Each vntItem In avntValues
            .Item(Key:=vntItem) = vbNullString
        Next
    End With
    
    'Create a New Presentation
    Set myPresentation = PowerPointApp.Presentations.Add
    
    'Loop through Month-Year-Column (only the filtered rows)
    For Each vntItem In objDictionary.keys
        
        Modul3.monthYearValue = vntItem
        
        'Add a slide to the Presentation
        Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
        'Set ranges
        
        Call Modul3.ws_Output.Rows(1).AutoFilter(Field:=1, Criteria1:=vntItem)
        
        Call Modul3.ws_Output.AutoFilter.Range.Copy
        
        DoEvents
        DoEvents
        
        'Paste to PowerPoint and position
        mySlide.Shapes.PasteSpecial DataType:=2 '6 = Paste as PNG
        Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
        
        myPresentation.Slides(1).Shapes.Title.TextFrame.TextRange.Text = _
            "VMI Consumption Data for " & Modul3.monthYearValue
        
        With myShape
            myShape.Width = 400
            myShape.Height = 300
            'higher Left -> more right direction moving
            myShape.Left = 150
            'higher Top -> more bottom direction moving
            myShape.Top = 130
            
        End With
        
    Next
    
    Call Modul3.ws_Output.ShowAllData
    
    
    'Make PowerPoint Visible and Active and FullScreen
    PowerPointApp.Visible = True
    PowerPointApp.Activate
    ' Application.DisplayFullScreen = True
    
    'Clear The Clipboard
    Application.CutCopyMode = False
    
    Set objDictionary = Nothing
    Set myShape = Nothing
    Set mySlide = Nothing
    Set myPresentation = Nothing
    Set PowerPointApp = Nothing
    
End Sub

Gruß
Nepumuk
Anzeige
AW: VBA: ExcelRange to PowerPoint-Slide
16.02.2020 20:48:15
Tobias
Hallo Nepumuk,
erstmal vielen Dank. Leider kam ein Laufzeitfehler 1004 mit der Meldung, dass der Autofilter nicht gesetzt werden konnte bei dem ersten Call-Aufruf in der For-Schleife.
Gruß
Tobias
AW: VBA: ExcelRange to PowerPoint-Slide
17.02.2020 08:11:40
Nepumuk
Hallo Tobias,
kannst du eine Beispielmappe hochladen?
Gruß
Nepumuk
AW: VBA: ExcelRange to PowerPoint-Slide
20.02.2020 13:44:52
Tobias
Hallo Nepumuk,
anbei die Beispieldatei. Das sind exemplarisch 2 Monate, zieht sich für die weiteren Monate nach diesem Schema durch.
Der Link:
https://www.herber.de/bbs/user/135317.xlsx
Vielen Dank und Grüße
Tobias
AW: VBA: ExcelRange to PowerPoint-Slide
21.02.2020 09:31:07
Nepumuk
Hallo Tobias,
funktioniert doch:
https://www.herber.de/bbs/user/135340.xlsm
Gruß
Nepumuk
Anzeige
AW: VBA: ExcelRange to PowerPoint-Slide
25.02.2020 20:19:19
Tobias
Hallo Nepumuk,
vielen Dank für deine Hilfe. Ja, funktioniert super. Hab da wohl etwas falsch gepastet. Entschuldigung für die späte Antwort.
Viele Grüße
Tobias

349 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige