Consulting

Results 1 to 11 of 11

Thread: Swapping table rows

  1. #1

    Swapping table rows

    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

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,794
    Location
    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.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    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...

  4. #4
    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

  5. #5
    VBAX Regular
    Joined
    Dec 2018
    Posts
    69
    Location
    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

  6. #6
    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

  7. #7
    VBAX Regular
    Joined
    Dec 2018
    Posts
    69
    Location
    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.

  8. #8
    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

  9. #9
    VBAX Regular
    Joined
    Dec 2018
    Posts
    69
    Location
    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

  10. #10
    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

  11. #11
    VBAX Regular
    Joined
    Dec 2018
    Posts
    69
    Location
    THANK YOU !!!!!!! Perfect! You're a star! Thanks for helping me learn.
    Have a great weekend

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •