VBA to continue tables on a new successive slide in PowerPoint

[Iorav Marz]

Hello,

I need to write some VBA code to continue tables that extend into the footer
table on successive slide(s). The code should go through all slides in the
PowerPoint file and:

1) Identify the first table that extends into or past the footer area of
the slide (below the 6.85" vertical position)
2) Insert a duplicate slide after the slide that contains this "extra-long"
table; this duplicate slide becomes a "continued" slide
3) Cut off the excessive rows in the "extra-long" table
4) Cut off the duplicate rows in the "continued" slide
5) Repeat for all extra-long tables in the PowerPoint file

I found some sample code that could prove useful under MSKB 240189; this
however does not apply for tables. Any ideas would be very much
appreciated... this is a time-consuming manual task that I hope can be
automated.

Sub ExpandSlide()
' Enable the error handler.
'
On Error GoTo ErrorHandler

Dim oShape As Shape
Dim i As Long
Dim oSlide As Slide
Dim strTitle As String
Dim lStrLen As Long
Dim lParas As Long
Dim lCurrIndex As Long
Dim lLastSlide As Long
Dim ErrMsg As String

' Check to see if the presentation is in the correct view.
' Raise the custom error message 555.
'
If ActiveWindow.ViewType <> ppViewNormal And ActiveWindow.ViewType _
<> ppViewSlide Then
Err.Raise 555, "Expand Slide Macro", _
"Not in Slide View or Normal View"
End If

With ActiveWindow.Selection
' Set lCurrIndex to the current slide index.
' Set lLastslide to the current slide index.
'
lCurrIndex = .SlideRange.SlideIndex
lLastSlide = lCurrIndex

' Check each shape of the current slide; check to
' see if it is a Body placeholder.
'
For Each oShape In .SlideRange.Shapes
If oShape.PlaceholderFormat.Type = ppPlaceholderBody Then

' Set lParas to the number of paragraphs in the
' Body placeholder. Does not differentiate between
' first level bullets and lower level bullets.
'
lParas = oShape.TextFrame.TextRange.Paragraphs.Count

For i = 1 To lParas

' Set strTitle to the current paragraph index.
'
strTitle = oShape.TextFrame.TextRange.Paragraphs(i).Text

' Determine how long the string is. Then, as long as
' it is not the last parapgraph in the Body placeholder,
' strip off the last two characters, the line feed and
' carriage return.
'
lStrLen = Len(strTitle)
If lParas <> i Then
strTitle = Left(strTitle, lStrLen - 2)
End If

' Set lLastSlide to the next available index position.
' Create a news slide, with the Bulleted Text layout.
' Assign the text from the current paragraph to the
' title placeholder. Return to the original slide.
'
lLastSlide = lLastSlide + 1
Set oSlide = _
ActivePresentation.Slides.Add(lLastSlide, ppLayoutText)
oSlide.Shapes(1).TextFrame.TextRange.Text = strTitle
ActiveWindow.View.GotoSlide (lCurrIndex)
Next i
End If
Next
End With
Exit Sub
ErrorHandler:
' Create Error message and raise dialog with error message.
'
ErrMsg = "Error:" & Err.Source & vbNewLine & Err.Description
MsgBox ErrMsg, vbCritical, "Error Message"
End Sub

 

[Shyam Pillai]

Here is an example of how to split a table.
http://skp.mvps.org/pptxp022.htm

You can extend it to your requirements.


--
Regards,
Shyam Pillai

Animation Carbon: Copy/Paste/Share animation libraries.
www.animationcarbon.com

 

[Iorav Marz]

This is a wonderful start but I have some follow up questions. I've tried the
sample code but need some help modifying it.

The core functionality of the code is great; it deletes rows off of a
selected table that extends past the bottom of a slide and inserts them in a
table on a new successive slide. However, how would I modify the code to meet
these requirements?

1) Making sure the first line in the selected table (which contains the
column headers) is always copied (right now the code just copies the extra
lines that fall off the page)
2) Retaining the formatting of the first row (and all rows if possible) on
the new table on the successive slide
3) Preventing the code from inserting a carriage return at the end of the
textrange of each copied cell; the current VBA inserts these extra carriage
returns

Thanks so much for your help.

 

[Shyam Pillai]

Please spend sometime in the VBA section of my site. There are several
examples to help you to arrive at your requirements. If still you don't get
it, then do post the code that is not working and I will be glad to help.


--
Regards,
Shyam Pillai

Animation Carbon: Copy/Paste/Share animation libraries.
www.animationcarbon.com

 

[Steve Rindsberg]

Hello,

I need to write some VBA code to continue tables that extend into the footer
table on successive slide(s). The code should go through all slides in the
PowerPoint file and:

1) Identify the first table that extends into or past the footer area of
the slide (below the 6.85" vertical position)
2) Insert a duplicate slide after the slide that contains this "extra-long"
table; this duplicate slide becomes a "continued" slide
3) Cut off the excessive rows in the "extra-long" table
4) Cut off the duplicate rows in the "continued" slide
5) Repeat for all extra-long tables in the PowerPoint file

This should get you going. It assumes you've already found a table to work
with and have a reference to it (in this case by selecting the table manually,)

It also leaves you some homework in the form of inserting the new slide, adding
a duplicate table to it and trimming the table. I can't grab ALL the fun for
myself.

Sub SplitTablePseudoCode()

' in this case, relies on you selecting a table first

Dim x As Long
Dim y As Long
Dim lCutoff As Long
Dim sCutoffPoint As Single

' we'll use the slide height as a crude measure of cutoff point
' substitute another value if you like
sCutoffPoint = ActivePresentation.PageSetup.SlideHeight

With ActiveWindow.Selection.ShapeRange(1)
If .HasTable Then
' it's a table
If .Top + .Height > sCutoffPoint Then
' it's off bottom of slide
' which cell should we cut it off at?
With .Table
For x = 1 To .Rows.Count
With .Cell(x, 1).Shape
If .Top + .Height > sCutoffPoint Then
lCutoff = x

' homework assignment:
' copy the whole table to a new slide
' trim off any rows < lCutoff

Exit For
End If
End With
Next

' trim the current table
For y = .Rows.Count To lCutoff Step -1
.Rows(y).Delete
Next

End With
End If
End If
End With

End Sub