CODEWITHSUNDEEP
excelvbapowerpoint
OliAK
OliAK

Reputation: 73

Pasting a large table into separate slides by Excel VBA

I would like to paste a table from excel to power point using VBA. However, as I have dynamic range therefore I would like to create slides with 15 rows only for better visualization. For example, it will paste row 1 to row 15 into slide number 1 then row 1, and row 16 to row 29 into slide number 2 and so on. Here row 1 is the header of the table. I have attached the code where I can create only one slide. I would highly appreciate if anyone can help me.

Sub SortingandSlidecreation()

    Dim pptName As String
    Dim ppt As PowerPoint.Application
    Dim myPres As PowerPoint.Presentation
    Dim slds As PowerPoint.Slides
    Dim sld As PowerPoint.slide
    Dim pptextbox As PowerPoint.Shape
    Dim oLayout As CustomLayout
    Dim wb As Workbook
    Dim ws As Worksheet

    Dim y As Workbook, LastRow&
    Dim r As Range


    Set wb = ThisWorkbook
    Set ws = wb.Sheets("SortedTable")

    'This will open a PowerPoint template (I didn't attach the function) 
    pptName = openDialog()                                              
    Set ppt = CreateObject("PowerPoint.Application")
    Set myPres = ppt.Presentations.Open(pptName)
    Set slds = myPres.Slides

    ' creating slides at the end of the template 
    Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)

    'Here data is selected for pasting
    Set r = ThisWorkbook.Worksheets("SortedTable").Range("A1:L" & LastRow)
    r.Copy
    sld.Shapes.PasteSpecial DataType:=0
    sld.Shapes(1).Top = 100
    sld.Shapes(1).Left = 100

    'Here title of the table is added
    Set pptextbox = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 22, 60, 700, 60)

    With pptextbox.TextFrame
        .TextRange.Text = "Summary of Current Projects"  
        .TextRange.Font.Bold = msoTrue
        .TextRange.Font.Name = "Arial(Headings)"
        .TextRange.Font.Size = 20
        .TextRange.Font.Color.RGB = RGB(0, 51, 102)
    End With

End Sub

Upvotes: 0

Views: 1446

Answers (1)

AAA
AAA

Reputation: 3670

Remove your current definition of LastRow. Then delete everything after your Set slds = myPres.Slides line and paste this code instead.

Dim LastRow as Long, i as Long, j as Integer, rngH as Range, wss as Worksheet
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rngH = ws.Range("A1:L1") 'Header Row
i = 2
Set wss = wb.Worksheets.Add

Do While i <= LastRow
    j = Application.Min(i + 13, LastRow)
    Union(rngH, ws.Range("A" & i, ws.Range("L" & j))).Copy Destination:= wss.Range("A1")
    Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)
    wss.Range("A1:L" & j-i+2).Copy
    sld.Shapes.PasteSpecial DataType:=0
    sld.Shapes(1).Top = 100
    sld.Shapes(1).Left = 100

    'Here title of the table is added
    Set pptextbox = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 22, 60, 700, 60)

    With pptextbox.TextFrame
        .TextRange.Text = "Summary of Current Projects"  
        .TextRange.Font.Bold = msoTrue
        .TextRange.Font.Name = "Arial(Headings)"
        .TextRange.Font.Size = 20
        .TextRange.Font.Color.RGB = RGB(0, 51, 102)
    End With
    i = j + 1
Loop

Application.DisplayAlerts = False
wss.Delete
Application.DisplayAlerts = True
Set wss = Nothing
End Sub

Upvotes: 1

Related Questions