Swapping table rows

[rdekanter]

Hello,

When I have a table on a slide, I often find that I sometimes want to move a row up or down one place. This involves manually adding a blank row, copy / pasting the two rows into the right order then deleting the additional row that will be left.

Unfortunately I've fallen at the first hurdle and can't seem to work out how to identify what table row is currently selected. Looping and using

If Table.Cell(i, 1).Selected = True Then
Does not appear to return true at any point.

Is there a way to determine the currently selected row of a PowerPoint table?
Additionally, is there a way to copy / paste entire rows of PowerPoint tables or would it need to be done one cell at a time?

thanks

[John Wilson]

You need to use

If Table.Cell(i, 1).Selected Then

Doesn't really make sense as it does return True but your original code always fails.

[rdekanter]

Ah yes, I've just noticed in debug mode that it the tooltip does evaluate to True = True but for some reason it doesn't move onto the encapsulated statement and instead moves back to the next iteration of the loop.

You have steered me though, as trying this does work:

For i = 1 To Table.Rows.Count
If Table.Cell(i, 1).Selected Then
Debug.Print i
End If
Next i

No idea why this is the case though. Onto the next problem...

[rdekanter]

Solution for anyone interested



Sub CET_ShiftRow(direction As String)


'Declare variables
Dim Table As Table
Dim row As Long
Dim i As Long
Dim j As Long


'Error handling
On Error GoTo Errhandler


With ActiveWindow.Selection
'Check that a single table is selected
If .ShapeRange.Count > 1 Then
MsgBox ("Error: Please select a single reference table")
Exit Sub
ElseIf .ShapeRange(1).HasTable <> msoTrue Then
MsgBox ("Error: Please select a single reference table")
Exit Sub
Else
Set Table = .ShapeRange(1).Table
End If
End With


'Loop through each row
For i = 1 To Table.Rows.Count
'Check if row has already been found
If row > 0 Then
'Exit loop as no need to complete it
Exit For
Else
'Check each cell in the row
For j = 1 To Table.Columns.Count
'Check if the cell is selected
If Table.Cell(i, j).Selected Then
row = i
Exit For
End If
Next j
End If
Next i


Select Case direction
Case Is = "MoveDown"
If row <> Table.Rows.Count Then
'Insert row above
Table.Rows.Add (row)

'Copy to row above
For j = 1 To Table.Columns.Count
Table.Cell(row, j).Shape.TextFrame.TextRange.Text = Table.Cell(row + 2, j).Shape.TextFrame.TextRange.Text
Next j

'Delete redundant row
Table.Rows(row + 2).Delete

'Retain selection of original row
Table.Cell(row + 1, 1).Select
End If

Case Is = "MoveUp"
If row <> 1 Then
'Insert row above
Table.Rows.Add (row - 1)

'Copy to row above
For j = 1 To Table.Columns.Count
Table.Cell(row - 1, j).Shape.TextFrame.TextRange.Text = Table.Cell(row + 1, j).Shape.TextFrame.TextRange.Text
Next j

'Delete redundant row
Table.Rows(row + 1).Delete

'Retain selection of original row
Table.Cell(row - 1, 1).Select
End If
End Select


Exit Sub


Errhandler:
MsgBox Error(Err)
Exit Sub


End Sub

[RayKay]

Hi rdekanter

A brilliant tool, but it doesn't work for me? I have PowerPoint 2013. The "CET_ShiftRow" doesn't show in the list of Macros.

If I change Sub CET_ShiftRow(direction As String) to Sub CET_ShiftRow() then CET_ShiftRow appears as a Macro, but nothing happens.

Any advice please? This tool is magnificent if I can get it to run.

Thank you :)

[rdekanter]

Sorry, it's technically incomplete as you need to call it with an argument from another sub.


Sub CET_ShiftRow(direction As String)

means that it needs a String input that the code will assign to a variable called "direction". If you look later in the code there is a Select statement based on this variable to determine whether the code shifts the row up or down. The cases are called "MoveUp" and "MoveDown", therefore you need to call the code as follows:


Call CET_ShiftRow("MoveUp")
or

Call CET_ShiftRow("MoveDown")

If you want to assign it to a shortcut or have it appear in your list of macros, simply create an additional pair of subs as follows:

Sub ShiftUp()

Call CET_ShiftRow("MoveUp")

End Sub
Sub ShiftDown()

Call CET_ShiftRow("MoveDown")

End Sub

[RayKay]

Hi rdkanter, thanks for a quick reply - though the VBA editor calls error on using:

Sub ShiftUp()
Call CET_ShiftRow("MoveUp")
[Then rest of your nice code]
End Sub

---------------------------Microsoft Visual Basic for Applications
---------------------------
Compile error:


Sub or Function not defined
---------------------------

I've tried various things, trial and error, and used the code you supplied, but I can't get it to work for me.

I know it sounds awful, but could you kindly post the code for ShiftUp? I'll then adapt it for ShiftDown. I just need it to appear in the Macro list too.
It's such an amazing feature and will make my life easier :)

Thank you. :cloud9:

[rdekanter]

It sounds like you've put the three parts together incorrectly - there should be three separate subs whereas what you posted suggests that you put the main one inside the other.

You need to have the first two copied in as above, then have the first piece of code that I put up after the "End Sub" statement. In other words,
ShiftUp()
ShiftDown()
Then
CET_ShiftRow(direction As String)

Or to correct what you put up:
Sub ShiftUp()
Call CET_ShiftRow("MoveUp")
[Then rest of your nice code] <-- Incorrect, this goes after the end of this subroutine, so swap it with the "End Sub" line
End Sub

[RayKay]

Hi, I'm so sorry, I tried various ways, I do feel stupid. I've tried various orders of code blocks, and no luck. Here's one of my efforts:

Sub ShiftUp()
Call CET_ShiftRow("MoveUp")
End Sub


Sub ShiftDown()
Call CET_ShiftRow("MoveDown")
End Sub


Select Case direction
Case Is = "MoveDown"
If row <> Table.Rows.Count Then
Table.Rows.Add (row)
For j = 1 To Table.Columns.Count
Table.Cell(row, j).Shape.TextFrame.TextRange.Text = Table.Cell(row + 2, j).Shape.TextFrame.TextRange.Text
Next j
Table.Rows(row + 2).Delete
Table.Cell(row + 1, 1).Select
End If

Case Is = "MoveUp"
If row <> 1 Then
Table.Rows.Add (row - 1)
For j = 1 To Table.Columns.Count
Table.Cell(row - 1, j).Shape.TextFrame.TextRange.Text = Table.Cell(row + 1, j).Shape.TextFrame.TextRange.Text
Next j
Table.Rows(row + 1).Delete
Table.Cell(row - 1, 1).Select
End If
End Select
Exit Sub


Dim Table As Table
Dim row As Long
Dim i As Long
Dim j As Long
On Error GoTo Errhandler


With ActiveWindow.Selection
If .ShapeRange.Count > 1 Then
MsgBox ("Error: Please select a single reference table")
Exit Sub
ElseIf .ShapeRange(1).HasTable <> msoTrue Then
MsgBox ("Error: Please select a single reference table")
Exit Sub
Else
Set Table = .ShapeRange(1).Table
End If
End With


For i = 1 To Table.Rows.Count
If row > 0 Then
Exit For
Else
For j = 1 To Table.Columns.Count
If Table.Cell(i, j).Selected Then
row = i
Exit For
End If
Next j
End If
Next i


Errhandler:
MsgBox Error(err)
Exit Sub
End Sub

[rdekanter]

It sounds like you need to start from basics again.

Generally speaking, any code should be wrapped inside its own subroutine - something that starts with "Sub NameForSomeCode()" and then ends in "End Sub".
Some subroutines can require a variable to be passed to it, e.g. "Sub NameForSomeCode(NameForVariable As VariableType)"

You have taken the the first two correctly, ShiftUp() and ShiftDown(). Each one of these calls a further sub "CET_ShiftRow()" and passes a String argument to it (either "MoveUp" or "MoveDown"). However, you do not have a sub called CET_ShiftRow() - you just have some orphaned code sitting on its own. For some reason you have only taken part of the code from my original sub. This won't work without the other parts.

To correct it, you will need to add my original solution to the second pair of subs:


Sub ShiftUp()
Call CET_ShiftRow("MoveUp")
End Sub

Sub ShiftDown()
Call CET_ShiftRow("MoveDown")
End Sub

​Sub CET_ShiftRow(direction As String)

'Declare variables
Dim Table As Table
Dim row As Long
Dim i As Long
Dim j As Long

'Error handling
On Error GoTo Errhandler

With ActiveWindow.Selection
'Check that a single table is selected
If .ShapeRange.Count > 1 Then
MsgBox ("Error: Please select a single reference table")
Exit Sub
ElseIf .ShapeRange(1).HasTable <> msoTrue Then
MsgBox ("Error: Please select a single reference table")
Exit Sub
Else
Set Table = .ShapeRange(1).Table
End If
End With

'Loop through each row
For i = 1 To Table.Rows.Count
'Check if row has already been found
If row > 0 Then
'Exit loop as no need to complete it
Exit For
Else
'Check each cell in the row
For j = 1 To Table.Columns.Count
'Check if the cell is selected
If Table.Cell(i, j).Selected Then
row = i
Exit For
End If
Next j
End If
Next i

Select Case direction
Case Is = "MoveDown"
If row <> Table.Rows.Count Then
'Insert row above
Table.Rows.Add (row)

'Copy to row above
For j = 1 To Table.Columns.Count
Table.Cell(row, j).Shape.TextFrame.TextRange.Text = Table.Cell(row + 2, j).Shape.TextFrame.TextRange.Text
Next j

'Delete redundant row
Table.Rows(row + 2).Delete

'Retain selection of original row
Table.Cell(row + 1, 1).Select
End If

Case Is = "MoveUp"
If row <> 1 Then
'Insert row above
Table.Rows.Add (row - 1)

'Copy to row above
For j = 1 To Table.Columns.Count
Table.Cell(row - 1, j).Shape.TextFrame.TextRange.Text = Table.Cell(row + 1, j).Shape.TextFrame.TextRange.Text
Next j

'Delete redundant row
Table.Rows(row + 1).Delete

'Retain selection of original row
Table.Cell(row - 1, 1).Select
End If
End Select

Exit Sub

Errhandler:
MsgBox Error(Err)
Exit Sub

End Sub

[RayKay]

THANK YOU !!!!!!! Perfect! You're a star! Thanks for helping me learn.
Have a great weekend :thumb