Solved: Regroup Tables?

Hi everyone...

I don't know why, but I work with a bunch of crazy people who think it's fun to ungroup tables. As you know, this wreaks havoc on the slide design as every cell turns into a separate textbox and there's no way to regroup it back into a table.

I did try something myself with just combining normal textboxes:
[vba]Sub MergeText()
On Error Resume Next
Dim shp As Shape
Dim sld As Slide
Dim myDocument As Slide
Dim mySlide As Integer
Dim tempText As String
'go through all shapes in the current slide & get the text
mySlide = ActiveWindow.View.Slide.SlideIndex
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
For Each shp In .ShapeRange
If shp.HasTextFrame Then
'APPEND all text together into temp variable
tempText = tempText & shp.TextFrame.TextRange & Chr$(13)
End If
Next shp
End If
End With
'dump the value of the tempText on the slide
Set myDocument = ActivePresentation.Slides(mySlide)
myDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=25.2, Top:=68.25, Width:=100, Height:=100).TextFrame.TextRange.Text = tempText

'Cleanup
'I can't remember the code to clean up variables - it has to do with setting them to NOTHING?
End Sub[/vba]

But with tables, it's a bit more difficult because (as far as I know) there's no way to know how many columns and rows there was. Would it be possible to expand this macro to make it regroup into a real table?

Good Evening.

Not having an example of one of your slides, I'm not entirely sure this would work, but here's just an idea...

You may be able to use the Least Common Multiple with each Row. For instance, say you have a a Table that is three rows high...

The brackets [ ] represent a cell.

Table:
[ Last Name ] [ First Name ]
[ Address ]
[City ] [ State ] [ Zip ]

Row 1 has 2 Cells
Row 2 has 1 Cell
Row 3 has 3 Cells

If you write out the Multiples:

| 2 | 4 | 6 | 8 | 10 | 12 |
| 1 | 2 | 3 | 4 | 5 | 6 |
| 3 | 6 | 9 | 12 | 15 | 18 |

You can see that each Row has a '6' Value, so theoretically, you would have have a Table that is 6 Columns by 3 Rows.
Row 1: Each cell is actually 2 merged cells.
Row 2: The cell is actually 6 merged cells.
Row 3: Each cell is actually 2 merged cells.


Of course this isn't perfect because it doesn't take into account that Row 3 could be 3 merged cells, 2 merged cells, and then 1 merged cell. But it's a thought.

Scott

Hi Scott,
That's an interesting perspective; something I never would have thought about. :)

I would prefer to keep it simple and assume each textbox is not merged. I try to stay away from merged cells because I'm used to them causing problems in Excel - I figured it was similar in PowerPoint.

I will attach my sample that I was using to test things.

The MergeText macro is what I posted above. The other one (MergeT) won't work because it's unfinished code. I was thinking of perhaps adding a msgbox that would ask the user if they're trying to regroup a table. If they choose no, I would just paste as usual. If they choose YES, i would ask how many columns and rows it is and paste into a table in reverse order. (you'll see why it needs to be reverse if you look at the example slide in my file)

p.s. - as an aside comment, what's the proper way to empty variables once I'm done with a subroutine? I can't remember the exact syntax.

Thanks much! :)
-Tom

Tom - you always have such interesting problems :yes You gotta straighten out those users

I don't think it's necessary to empty variables if you're exiting a function or a sub. Excel is supposed to do it's garbage collection at that point

http://www.vbaexpress.com/forum/arch...php/t-888.html


The only way I know to release an object is to Set objThing = Nothing and Erase for arrays

Lots of good tips in the link

Paul

I set this project aside for a while but it has come back into focus. The bold areas are where I need help (I can't seem to grasp the concept of arrays - or when I need to use them).

Here's what my code is so far:
[vba]
Sub MergeText()
On Error Resume Next
Dim shp As Shape
Dim sld As Slide
Dim myDocument As Slide
Dim mySlide As Integer
Dim tempText As String
Dim Response As Long
Dim rowsReply As Long
Dim colsReply As Long
Dim MyString As String
Dim txtArray As Variant

'go through everything in the current selection & get the text
mySlide = ActiveWindow.View.Slide.SlideIndex
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
For Each shp In .ShapeRange
If shp.HasTextFrame Then
'APPEND all text together into temp variable
tempText = tempText & shp.TextFrame.TextRange & Chr$(13)
End If
Next shp
End If
End With

'Ask if the selection used to be a table
'If NO, paste normally | If YES, paste the text in reverse order
Response = msgbox("Is the selection an ungrouped table?", 3, "Please answer...")
If Response = vbYes Then ' User chose Yes
MyString = "Yes"
'Ask how many rows and columns
colsReply = InputBox("How many columns?", "Columns", 4)
rowsReply = InputBox("How many rows?", "Rows", 4)
'dump the text into an array <--- Not sure how to do this

'(size of table based on rowsReply, colsReply)
Set myDocument = ActivePresentation.Slides(mySlide)
myDocument.Shapes.AddTable(rowsReply, colsReply).Name = "temptable" & mySlide
With myDocument.Shapes.Range("temptable" & mySlide)
'Paste the contents of the array in reverse order into the table <--- Not sure how to do this

End With
ElseIf Response = vbNo Then ' User chose No
MyString = "No"
'dump the value of the tempText on the slide
Set myDocument = ActivePresentation.Slides(mySlide)
myDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=25.2, Top:=68.25, Width:=100, Height:=100).TextFrame.TextRange.Text = tempText
End If

End Sub
[/vba]
I was planning on doing this:
1) ask user if their selection is an ungrouped table
2a) if yes, find out how many columns and rows there used to be. Then I could take that information and dump the text from the selection into an array, and paste, in reverse order, into a table (size based on the cols/rows they specify).
2b) if no, paste into a normal textbox

Is my logic thorough enough or should I think it through more? (looks at Fumei) ;)

Hi Tom

Sorta busy right now so these are just pointers

Dim your array like this

[vba]Dim raytxt() as string[/vba]

Then to dump tempText into the array

[vba]raytxt=Split(tempText,Chr$(13))[/vba]

To get the text back

[vba]For i= Ubound(raytxt) to 0 step-1
'do something with raytxt(i)
next i[/vba]

Ok, based on your suggestions, I modified my code to this:
[vba]
Sub MergeText()
On Error Resume Next
Dim shp As Shape
Dim mySlide As Integer
Dim tempText As String
Dim Response As Long
Dim rowsReply As Long, colsReply As Long
Dim MyString As String
Dim oTable As Table
Dim I As Long, M As Long, N As Long
Dim txtArray() As String

'go through everything in the current selection & get the text
mySlide = ActiveWindow.View.Slide.SlideIndex
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
For Each shp In .ShapeRange
If shp.HasTextFrame Then
'APPEND all text together into temp variable
tempText = tempText & shp.TextFrame.TextRange & Chr$(13)
End If
Next shp
End If
End With

'Ask if the selection used to be a table
'If NO, paste normally | If YES, paste the text in reverse order
Response = msgbox("Is the selection an ungrouped table?", 3, "Please answer...")
If Response = vbYes Then ' User chose Yes
MyString = "Yes"

'Ask how many rows and columns
colsReply = InputBox("How many columns?", "Columns", 4)
rowsReply = InputBox("How many rows?", "Rows", 4)

'dump the text into an array
txtArray() = Split(tempText, vbCr)

'(size of table based on rowsReply, colsReply)
ActivePresentation.Slides(mySlide).Shapes.AddTable(rowsReply, colsReply).Name = "temptable" & mySlide
Set oTable = ActivePresentation.Slides(mySlide).Shapes("temptable" & mySlide)
With oTable
'Paste the contents of the array in reverse order into the table
For I = UBound(txtArray) To 0 Step -1
'do something with txtArray(i)
For M = 1 To rowsReply
For N = 1 To colsReply
.Cell(M, N).Shape.TextFrame.TextRange.Text = txtArray(I)
Next N
Next M
Next I
End With
ElseIf Response = vbNo Then ' User chose No
MyString = "No"
'dump the value of the tempText on the slide
ActivePresentation.Slides(mySlide).Shapes.AddTextbox(msoTextOrientationHori zontal, _
Left:=25.2, Top:=68.25, Width:=100, Height:=100).TextFrame.TextRange.Text = tempText
End If
End Sub
[/vba]

But it's still not putting the contents of the array into the cells. I'm not sure what I'm doing wrong. I tried replacing

Quote:

---

.Cell(M, N).Shape.TextFrame.TextRange.Text = txtArray(I)

---

with

Quote:

---

.Cell(M, N).Shape.TextFrame.TextRange.Text = "test"

---

and it still didn't put text in the table, so I'm not sure what's going on.

I had an error in my "Set oTable" line...
After I fixed that, the text showed up revealing that I had to figure out a different way to use looping. But I can't figure out the best way to do the looping to get what I'm after.

It's currently putting the last value in all the cells of the table. I need it to put each separate value in the array into separate cells of the table. Here's my code:
[vba]
Sub MergeText()
'On Error Resume Next
Dim shp As Shape
Dim mySlide As Integer
Dim tempText As String
Dim Response As Long
Dim rowsReply As Long, colsReply As Long
Dim MyString As String
Dim oTable As Table
Dim I As Long, M As Long, N As Long
Dim txtArray() As String

'go through everything in the current selection & get the text
mySlide = ActiveWindow.View.Slide.SlideIndex
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
For Each shp In .ShapeRange
If shp.HasTextFrame Then
'APPEND all text together into temp variable
tempText = tempText & shp.TextFrame.TextRange & Chr$(13)
End If
Next shp
End If
End With

'Ask if the selection used to be a table
'If NO, paste normally | If YES, paste the text in reverse order
Response = msgbox("Is the selection an ungrouped table?", 3, "Please answer...")
If Response = vbYes Then ' User chose Yes
MyString = "Yes"

'Ask how many rows and columns
colsReply = InputBox("How many columns?", "Columns", 4)
rowsReply = InputBox("How many rows?", "Rows", 4)

'dump the text into an array
txtArray() = Split(tempText, vbCr)

'(size of table based on rowsReply, colsReply)
ActivePresentation.Slides(mySlide).Shapes.AddTable(rowsReply, colsReply).Name = "temptable" & mySlide
Set oTable = ActivePresentation.Slides(mySlide).Shapes("temptable" & mySlide).Table

'Paste the contents of the array in reverse order into the table
For I = UBound(txtArray) To 0 Step -1
'do something with txtArray(i)
For M = 1 To rowsReply
For N = 1 To colsReply
oTable.Rows(M).Cells(N).Shape.TextFrame.TextRange.Text = txtArray(I)
Next N
Next M
Next I

ElseIf Response = vbNo Then ' User chose No
MyString = "No"
'dump the value of the tempText on the slide
ActivePresentation.Slides(mySlide).Shapes.AddTextbox(msoTextOrientationHori zontal, _
Left:=25, Top:=68, Width:=100, Height:=100).TextFrame.TextRange.Text = tempText
End If
End Sub
[/vba]

So I think I have to get rid of the outer loop, but if I do that, how can I refer to the right index in the Array?

Would it make it any easier if the array was 2-dimensional (like a table)?

Hi Tom

Met my urgent deadline so I am not QUITE so busy!

You are right you must add the text from the array to the correct cell NOT loop round ALL cells

Also (my mistake) you need to account for the first array value being txtArray(0) not as you might expect txtArray(1)

Forgive me if you are good at math and I am talking down to you here!

The loop needs to be UBound(txtArray)-1 to 0

and the math for the correct cell is

M=(I \ rowsReply)+1 [ NB backslash= INTEGER division]
N=(I Mod rowsReply) +1

So that section of the code would be

[vba] For I = (UBound(txtArray) - 1) To 0 Step -1 'account for array starts at zero
'do something with txtArray(i)
M = (I \ rowsReply) + 1 ' note \ = integer division
N = (I Mod rowsReply) + 1
.Cell(M, N).Shape.TextFrame.TextRange = txtArray(I)
Next I[/vba]

Few more points I wouldn't use Chr$(13) as your seperator as it may occur in the original table Maybe use something unlikely like Chr$135 don't forget to change it in the Split too!

I would tag the original shapes so the can be deleted later

[vba]shp.Tags.Add, "DELETE","YES"[/vba]

The order of text in the new table will depend on the original selection order. This will be fairly hard to fix!

You might wan't to read my vba tute on Input boxes too
http://www.pptalchemy.co.uk/powerpoi...rials.html#vba

Hope that gets you on the right track

John

Thanks John,
I can't wait to try all your suggestions, but right now I'm headed out for a birthday bash. :)

If you try this on a table that doesn't have the same number of columns as rows it errors out. For instance, 3 cols, 2 rows.

2x2 works, but it pastes the names in reverse order. I think it's because of the structure of an ungrouped table. It seems the last row/col becomes the top-most "layer" and each subsequent textbox is "behind" the other. That's why I thought I would have to paste the array in reverse order starting in the upper left cell.

I'm not very good with math when it comes to this kind of thing, so you didn't offend me with that part. :) I don't understand what that part is doing to figure out which part of the array to use.

Hi Tom

There's a typo in my math code

rowsReply should be colsReply

Here's what it tries to do

Say you have a 3 x 5 table there will be 15 values in the text array, textArray(0) to textArray(14). Consider the last> textArray(14) which should go in Cell(3,5)
14\5(cols)=2 and 2+1=3= Row
14 mod 5 = 4 and 4+1 =5 = Column (mod is basically "remainder" when you divide > 14 mod 5 = 2 remainder 4)

The order will depend on HOW the user selects the shapes originally. If they select one by one with ctrl click from the start it will give a different result than dragging a selection box for example. Checking every possible combo is going to be hard but you may be able to check for the shaperange being in forward or reverse order (the most likely problem) fairly easily by comparing the top and left value for ShapeRange(1) with those for .ShapeRange(.Shaperange.Count). You would then need to reverse (or not) the initial loop that gathers the textranges.

You would need to alter the type of loop to do this

For i = 1 to 1 to .ShapeRangeCount
shp= .ShapeRange(i)

OR depending on the check

For i = .ShapeRangeCount to 1 Step -1
shp= .ShapeRange(i)

Yes, I did notice it goes in the correct order if you select the cells one-by-one, but if you just draw a selection area around the whole thing, no matter how you draw the bounding box, it goes in reverse order.

I'm assuming a basic table here - no merged cells.

Now I have to read your post again because I want to make sure I understand it. :) Thanks for the explanation.

Does this work?
[VBA]Sub MergeText()
On Error Resume Next
Dim shp As Shape
Dim mySlide As Slide
Dim tempText As String
Dim Response As Long
Dim rowsReply As Long, colsReply As Long
Dim MyString As String
Dim IDir As Integer
Dim I As Long, M As Long, N As Long
Dim txtArray() As String

'go through everything in the current selection & get the text
Set mySlide = ActiveWindow.View.Slide
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
If .ShapeRange(1).Left > .ShapeRange(.ShapeRange.Count).Left Then

For I = 1 To .ShapeRange.Count
Set shp = mySlide.Shapes(I)
If shp.HasTextFrame Then
'APPEND all text together into temp variable
tempText = tempText & shp.TextFrame.TextRange & Chr$(135)
End If
Next I

Else
For I = .ShapeRange.Count To 1 Step -1
Set shp = mySlide.Shapes(I)
If shp.HasTextFrame Then
'APPEND all text together into temp variable
tempText = tempText & shp.TextFrame.TextRange & Chr$(135)
End If
Next I
End If
End If
End With

'Ask if the selection used to be a table
'If NO, paste normally | If YES, paste the text in reverse order
Response = MsgBox("Is the selection an ungrouped table?", 3, "Please answer...")
If Response = vbYes Then ' User chose Yes
MyString = "Yes"

'Ask how many rows and columns
colsReply = InputBox("How many columns?", "Columns", 4)
rowsReply = InputBox("How many rows?", "Rows", 4)

'dump the text into an array
txtArray() = Split(tempText, Chr$(135))
Debug.Print txtArray(0)

'(size of table based on rowsReply, colsReply)
With mySlide.Shapes.AddTable(rowsReply, colsReply).Table


'Paste the contents of the array in reverse order into the table
For I = UBound(txtArray) - 1 To 0 Step -1
'do something with txtArray(i)
M = (I \ colsReply) + 1
N = (I Mod colsReply) + 1
.Cell(M, N).Shape.TextFrame.TextRange = txtArray(I)
Next I
End With
ElseIf Response = vbNo Then ' User chose No
MyString = "No"
'dump the value of the tempText on the slide
mySlide.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=25.2, Top:=68.25, Width:=100, Height:=100).TextFrame.TextRange.Text = tempText
End If
End Sub[/VBA]

It's only returning letters in the cells instead of the actual text from the original table. I played around with the code and to be honest, I'm not sure how I got it to work, but for what it's worth, I'll post it below.
[vba]Sub MergeText()
'On Error Resume Next
Dim shp As Shape
Dim mySlide As Integer
Dim tempText As String
Dim Response As Long
Dim rowsReply As Long, colsReply As Long
Dim MyString As String
Dim oTable As Table
Dim I As Long, M As Long, N As Long
Dim txtArray() As String

'go through everything in the current selection & get the text
mySlide = ActiveWindow.View.Slide.SlideIndex
With ActiveWindow.Selection
If .Type = ppSelectionShapes Then
For Each shp In .ShapeRange
If shp.HasTextFrame Then
'Check for forward or reverse order
If .ShapeRange(1).Left < .ShapeRange(.ShapeRange.Count).Left Then
tempText = shp.TextFrame.TextRange & Chr$(135) & tempText
Else
tempText = tempText & shp.TextFrame.TextRange & Chr$(135)
End If
End If
Next shp
End If
End With

'Ask if the selection used to be a table
'If NO, paste normally | If YES, paste the text in reverse order
Response = MsgBox("Is the selection an ungrouped table?", 3, "Please answer...")
If Response = vbYes Then ' User chose Yes
MyString = "Yes"

'Ask how many rows and columns
colsReply = InputBox("How many columns?", "Columns")
rowsReply = InputBox("How many rows?", "Rows")

'dump the text into an array
txtArray() = Split(tempText, Chr$(135))

'(size of table based on rowsReply, colsReply)
ActivePresentation.Slides(mySlide).Shapes.AddTable(rowsReply, colsReply).Name = "temptable" & mySlide
Set oTable = ActivePresentation.Slides(mySlide).Shapes("temptable" & mySlide).Table

'Paste the contents of the array in reverse order into the table
For I = 0 To (UBound(txtArray) - 1) 'account for array starts at zero
'do something with txtArray(i)
M = (I \ colsReply) + 1 ' note \ = integer division
N = (I Mod colsReply) + 1
oTable.Cell(M, N).Shape.TextFrame.TextRange = txtArray(I)
Next I

ElseIf Response = vbNo Then ' User chose No
MyString = "No"
'dump the value of the tempText on the slide
txtArray() = Split(tempText, Chr$(135))
For I = 0 To (UBound(txtArray) - 1)
If I = 0 Then
tempText = txtArray(I) & vbCr
Else
tempText = tempText & txtArray(I) & vbCr
End If
Next I

ActivePresentation.Slides(mySlide).Shapes.AddTextbox(msoTextOrientationHori zontal, _
Left:=25, Top:=68, Width:=100, Height:=100).TextFrame.TextRange.Text = tempText
End If
End Sub
[/vba]
It's probably not the best solution (mine never are) but I'm satisfied enough to mark the thread solved. Thanks for all your help. :friends:

Funny,
It worked perfectly at home, but when I bring it to work the order turns out not to be predictable, as you said in your earlier post.

Ugh, what a mess!

I thought that would happen! Maybe a totally different approach is needed.

Select ONLY the first cell in the ungrouped table and run this

[vba]Sub maketbl()
Dim osld As Slide
Dim oshp As Shape
Dim strColNum As String
Dim strRowNum As String
Dim Icol As Integer
Dim Irow As Integer
Dim iR As Integer
Dim iC As Integer
Dim Istart As Integer
Dim adj As Integer
Dim i As Integer

Set osld = ActiveWindow.View.Slide
If ActiveWindow.Selection.Type = ppSelectionNone Then Exit Sub

If ActiveWindow.Selection.Type = ppSelectionShapes Then
Set oshp = ActiveWindow.Selection.ShapeRange(1)
ElseIf ActiveWindow.Selection.Type = ppSelectionText Then
Set oshp = ActiveWindow.Selection.TextRange.Parent.Parent
End If
If oshp.Type = msoTable Then
MsgBox "This table is NOT ungrouped!"
Exit Sub
End If
If Not oshp.Name Like "Rectangle*" Then
MsgBox "Did you select a former table cell?"
Exit Sub
End If
With ActiveWindow.Selection.ShapeRange(1)
Istart = Int(Right$(.Name, Len(.Name) - 10))
End With
Do
strColNum = InputBox("Please enter the Number of COLUMNS")
If StrPtr(strColNum) = False Then Exit Sub 'cancel pressed
Loop Until IsNumeric(strColNum) 'not a number try again
Icol = Int(strColNum)
Do
strRowNum = InputBox("Please enter the Number of ROWS")
If StrPtr(strRowNum) = False Then Exit Sub
Loop Until IsNumeric(strRowNum)
Irow = Int(strRowNum)
With osld.Shapes.AddTable(Irow, Icol).Table
For iR = 1 To .Rows.Count
For iC = 1 To .Columns.Count
.Cell(iR, iC).Shape.TextFrame.TextRange = osld.Shapes("Rectangle " & CStr(Istart + adj)).TextFrame.TextRange
osld.Shapes("Rectangle " & CStr(Istart + adj)).Delete
adj = adj + 1
Next iC
Next iR
End With
'optional try to delete original!
For i = Istart + adj To Istart + adj + (Icol) + (Irow + 1)
osld.Shapes("Line " & CStr(i)).Delete
Next i
End Sub

[/vba]

Holy cow John!
That is amazing!!!

I was busy at work today so I didn't notice you posted this until I got home. That's funny cuz as I was riding in the car, I was thinking of alternative ways to get this to work. I was thinking maybe I could put the "top" and "left" values of the selected shapes into a 2-dimensional array and sort it from least to greatest to get the upper left to lower right values.

But your code works great for me at home. I'm excited to try it when I get to work tomorrow! This will save me a lot of time, truely! :bow: Thank you so much.

Now to go thru your code and see exactly how it works.... I love learning new things.

That's great Tom

You will probaly need a little more error checking or at least On Error Resume Next!

I've added a couple of things I have learned over the years which are often useful so I'll explain them.

[vba] Set oshp = ActiveWindow.Selection.TextRange.Parent.Parent[/vba]
When you ask people to select a shape with text they often put the cursor in the text effectively selecting the textrange.

The parent of TextRange is TextFrame and it's Parent is the Shape hence Parent.Parent

The use of a loop and StrPtr (string pointer) in the input box. The loop simply ensures they enter a number not eg "One" or "What?"!! The problem comes if the hit cancel, Input box sees this as Not a number and keeps looping. StrPrt is a little known feature that points to the address of the string in memory. It will do this even if the string is "" but not if there is NO string at all as when cancel is pressed.

How it works

Finds the name of the shape which will be Rectangle xx
Works out the value of xx and then the name of the other shapes by adding one to the value in the name on each loop. The delete Lines feature is maybe a little dodgy as the user may have deleted borders. Definitely add On Error Resume Next here.

Here endeth the lesson!

Ok, just to make sure I know what's going on:

[vba]Istart = Int(Right$(.Name, Len(.Name) - 10))[/vba] This line basically takes the name of the selected shape, parses the number out of it and assigns it to Istart. So basically I can't select a shape with a name more than 99 (god I hope I never have a table with that many cells!)

That part I understand (clever by the way).. ;)

This is where I got confused:
[vba]For iC = 1 To .Columns.Count
.Cell(iR, iC).Shape.TextFrame.TextRange = osld.Shapes("Rectangle " & CStr(Istart + adj)).TextFrame.TextRange
osld.Shapes("Rectangle " & CStr(Istart + adj)).Delete
adj = adj + 1
Next iC[/vba] What does the CStr(Istart + adj)) part of that code do? What is adj for?

Point 1
It should parse any number It basically takes the name and strips out "Rectangle " (10 letters inc the space)

Point 2
The adj(ust) just adds one to the number for each new cell. CStr converts the number to a string

eg
"Rectangle " & CStr(6) = "Rectangle 6"
then "Rectangle 7"
then "Rectangle 8" etc

This puts the correct textrange into the correct cell (hopefully)

Note this will hardly ever start at Rectangle 1 because of the way PPT names shapes (in the testing I was on Rectangle 297!!)

John -- I am consistantly impressed by your knowledge of the nuances of PP and getting VBA to do things
:beerchug:

You are NOT allowed to ever let your VBX membership expire :thumb

Paul

The beer tasted good!