Macro which generates Powerpoint slides

[Corleone]

I have the following macro which works fine for copying a series of dashboards which sit one underneath the other into powerpoint slides.

Its set up so that it selects 36 rows per slide (this is the amount of rows which make up each dashboard) and then goes in a loop right down to the bottom f the data generating slides for all the dashboards on the sheet. (down to roughly row 3000 (so around 80 dashboards)

There is a function on the spreadsheet which will allow me to just filter on certain dashboards (eg ones that sit under a particular project manager)

However i have a slight issue on when i run the macro with a filter on - if I have it filtered on a certain project manager for example it will show the 3rd / 5th and 7th dashboards only in excel - when you run the macro it will generate the 3rd / 5th and 7th slide but it also generates 77 other blank slides as it goes through from row 1 all the way to row 3000.

I would like to amend it so that it just generated the slides in PPT based on what the filter is on
Thanks


Sub Copy_Excel_To_PPT()
Dim PPT_App As Object
Dim ppt_file As Object
Dim my_slide As Object
Set PPT_App = CreateObject("PowerPoint.Application")
Set ppt_file = PPT_App.Presentations.Add
Dim sh As Worksheet
Dim dataRange As Range
Dim lastRow As Long
Dim slideIndex As Long
Dim rowCount As Long

slideIndex = 1 ' Slide index counter
rowCount = 36 ' Number of rows per slide

For Each sh In ThisWorkbook.Sheets
If sh.Name = "POAP All Projects" Then
lastRow = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row
Set dataRange = sh.Range("C1:Z" & lastRow) ' Adjust the range to include the headers if necessary

' Iterate through the rows in the data range
For i = 4 To lastRow Step rowCount ' Start from row 4
Set my_slide = ppt_file.Slides.AddSlide(slideIndex, ppt_file.SlideMaster.CustomLayouts(6))
slideIndex = slideIndex + 1

'''''' Format Slide title
With my_slide.Shapes.Title
.TextFrame.TextRange.Text = sh.Name & " - Slide " & slideIndex
.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
.Fill.BackColor.RGB = RGB(0, 128, 128)
.TextEffect.Alignment = msoTextEffectAlignmentCentered
.TextEffect.FontName = "Arial Rounded MT Bold"
.Height = 0
End With

' Calculate the range for the current slide
Dim startRow As Long
Dim endRow As Long
startRow = i
endRow = i + rowCount - 1

' Ensure the range does not exceed the last row
If endRow > lastRow Then
endRow = lastRow
End If

' Set the data range for the current slide
Set dataRange = sh.Range("C" & startRow & ":Z" & endRow)

' Copy data range to clipboard
dataRange.CopyPicture xlScreen, xlPicture

' Paste the data range as a picture
my_slide.Shapes.Paste

''''''' Resize and reposition the picture
With my_slide.Shapes(my_slide.Shapes.Count)
.LockAspectRatio = msoCTrue
.Width = ppt_file.PageSetup.SlideWidth - 1
.Top = ppt_file.PageSetup.SlideHeight * 0.04 ' 4 cm margin at the top
If .Height > ppt_file.PageSetup.SlideHeight Then
.Height = ppt_file.PageSetup.SlideHeight - 20
End If
.Left = 0
If .Width > ppt_file.PageSetup.SlideWidth Then
.Width = ppt_file.PageSetup.SlideWidth - 1
End If
.Left = (ppt_file.PageSetup.SlideWidth - .Width) / 2
.Top = .Top + 10
End With
Next i
End If
Next

PPT_App.Visible = True ' Show PowerPoint application

Set PPT_App = Nothing
Set ppt_file = Nothing
Set my_slide = Nothing
Set sh = Nothing
Set dataRange = Nothing
End Sub

 

[sijpie]

Corleone, with 800+ posts to your name, you should know that you need to put code tags around your code. A lot of people will refuse to answer your post if you don't. So necxt time, click the little VBA icon and then paste your code.

 

[sijpie]

Try this. It assumes that the unwanted rows are hidden through the filter.

Sub Copy_Excel_To_PPT()
    Dim PPT_App As Object
    Dim ppt_file As Object
    Dim my_slide As Object
    Set PPT_App = CreateObject("PowerPoint.Application")
    Set ppt_file = PPT_App.Presentations.Add
    Dim sh As Worksheet
    Dim dataRange As Range
    Dim lastRow As Long
    Dim slideIndex As Long
    Dim rowCount As Long
   
    slideIndex = 1 ' Slide index counter
    rowCount = 36 ' Number of rows per slide
   
    For Each sh In ThisWorkbook.Sheets
        If sh.Name = "POAP All Projects" Then
            lastRow = sh.Cells(sh.Rows.Count, "C").End(xlUp).Row
            Set dataRange = sh.Range("C1:Z" & lastRow) ' Adjust the range to include the headers if necessary
           
            ' Iterate through the rows in the data range
            For i = 4 To lastRow Step rowCount ' Start from row 4
               
                ' Calculate the range for the current slide
                Dim startRow As Long
                Dim endRow As Long
                startRow = i
                endRow = i + rowCount - 1
               
                ' Ensure the range does not exceed the last row
                If endRow > lastRow Then
                    endRow = lastRow
                End If
               
                On Error GoTo GotToNextGroup        ' If the rows are hidden, the next line will throw an error. _
                                                      This will then make the macro skip this block and ppt sheet
                If sh.Range("C" & startRow).SpecialCells(xlCellTypeVisible) Then
                    On Error goto 0
                    ' Set the data range for the current slide
                    Set dataRange = sh.Range("C" & startRow & ":Z" & endRow)
                   
                    ' Copy data range to clipboard
                    dataRange.CopyPicture xlScreen, xlPicture
                   
                    Set my_slide = ppt_file.Slides.AddSlide(slideIndex, ppt_file.SlideMaster.CustomLayouts(6))
                    slideIndex = slideIndex + 1
                   
                    '''''' Format Slide title
                    With my_slide.Shapes.Title
                        .TextFrame.TextRange.Text = sh.Name & " - Slide " & slideIndex
                        .TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
                        .Fill.BackColor.RGB = RGB(0, 128, 128)
                        .TextEffect.Alignment = msoTextEffectAlignmentCentered
                        .TextEffect.FontName = "Arial Rounded MT Bold"
                        .Height = 0
                    End With
                    ' Paste the data range as a picture
                    my_slide.Shapes.Paste
                   
                    ''''''' Resize and reposition the picture
                    With my_slide.Shapes(my_slide.Shapes.Count)
                        .LockAspectRatio = msoCTrue
                        .Width = ppt_file.PageSetup.SlideWidth - 1
                        .Top = ppt_file.PageSetup.SlideHeight * 0.04 ' 4 cm margin at the top
                        If .Height > ppt_file.PageSetup.SlideHeight Then
                            .Height = ppt_file.PageSetup.SlideHeight - 20
                        End If
                        .Left = 0
                        If .Width > ppt_file.PageSetup.SlideWidth Then
                            .Width = ppt_file.PageSetup.SlideWidth - 1
                        End If
                        .Left = (ppt_file.PageSetup.SlideWidth - .Width) / 2
                        .Top = .Top + 10
                    End With
                End If
GotToNextGroup:
                On Error goto 0
            Next i
        End If
    Next
   
    PPT_App.Visible = True ' Show PowerPoint application
   
    Set PPT_App = Nothing
    Set ppt_file = Nothing
    Set my_slide = Nothing
    Set sh = Nothing
    Set dataRange = Nothing
End Sub