Solved: Regroup Tables?

[TrippyTom]

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?

[Demosthine]

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

[TrippyTom]

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

[Paul_Hossler]

Tom - you always have such interesting problems 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

[TrippyTom]

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)

[John Wilson]

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]

[John Wilson]

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]

[TrippyTom]

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.

[TrippyTom]

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!

[John Wilson]

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]

[TrippyTom]

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! Thank you so much.

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

[John Wilson]

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!

[TrippyTom]

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?

[Paul_Hossler]

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


You are NOT allowed to ever let your VBX membership expire

Paul

[John Wilson]

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 Wilson]

The beer tasted good!