Transpose table in Powerpoint VBA

Question

I was looking for button where I can transpose the table on one click in powerpoint, I have tried few script's but it's not working for me, sharing below for you to understand what I am trying, and Looking for your help to correct me where I am doing wrong.

Sub TransposeTable()
    Dim slide As Slide
    Dim table As Table
    Dim numRows As Long
    Dim numCols As Long
    Dim i As Long
    Dim j As Long
    Dim tempArray() As Variant
    Dim newTable As Table
    
    ' Check if the first slide is selected and has a table
    If ActiveWindow.Selection.Type <> ppSelectionSlides Then
        MsgBox "Please select a slide.", vbExclamation
        Exit Sub
    End If
    
    Set slide = ActiveWindow.Selection.SlideRange(1)
    
    ' Check if the first shape on the slide is a table
    If slide.Shapes.Count = 0 Then
        MsgBox "The selected slide does not have any shapes.", vbExclamation
        Exit Sub
    End If
    
    For Each shape In slide.Shapes
        If shape.Type = msoTable Then
            Set table = shape.Table
            numRows = table.Rows.Count
            numCols = table.Columns.Count
            
            ' Create a temporary array to store the transposed table data
            ReDim tempArray(1 To numCols, 1 To numRows)
            
            ' Transpose the table data into the temporary array
            For i = 1 To numRows
                For j = 1 To numCols
                    tempArray(j, i) = table.Cell(i, j).Shape.TextFrame.TextRange.Text
                Next j
            Next i
            
            ' Delete the existing table
            table.Delete
            
            ' Create a new transposed table at the same position
            Set newTable = slide.Shapes.AddTable(NumRows:=numCols, NumColumns:=numRows, Left:=shape.Left, Top:=shape.Top, Width:=shape.Height, Height:=shape.Width).Table
            
            ' Populate the new table with the transposed data
            For i = 1 To numCols
                For j = 1 To numRows
                    newTable.Cell(i, j).Shape.TextFrame.TextRange.Text = tempArray(i, j)
                Next j
            Next i
            
            Exit Sub ' Transpose only the first table found
        End If
    Next shape
    
    ' No table found
    MsgBox "The selected slide does not contain a table.", vbExclamation
End Sub

Answer 1

There are two problems in your code: 1. A table cannot be deleted in the way you try, its parent/the shape should be deleted. 2. After deleting the shape, the reference to it is lost. So you must preliminarily memorize the involved shape necessary properties (Left, Top, Height and Width) and use them after deletion:

Sub TransposeTable()
    Dim slide As slide, table As table, numRows As Long, numCols As Long
    Dim i As Long, j As Long, tempArray() As Variant
    Dim newTable As table, Sh As Shape, shLeft As Double, shTop As Double, shHeight As Double, shWidth As Double
    
    ' Check if the first slide is selected and has a table
    If ActiveWindow.Selection.Type <> ppSelectionSlides Then
        MsgBox "Please select a slide.", vbExclamation
        Exit Sub
    End If
    
    Set slide = ActiveWindow.Selection.SlideRange(1)
    
    ' Check if the first Sh on the slide is a table
    If slide.Shapes.Count = 0 Then
        MsgBox "The selected slide does not have any Shs.", vbExclamation
        Exit Sub
    End If
    
    For Each Sh In slide.Shapes
        If Sh.Type = msoTable Then
            Set table = Sh.table
            numRows = table.Rows.Count
            numCols = table.Columns.Count
            
            ' Create a temporary array to store the transposed table data
            ReDim tempArray(1 To numCols, 1 To numRows)
            
            ' Transpose the table data into the temporary array
            For i = 1 To numRows
                For j = 1 To numCols
                    tempArray(j, i) = table.Cell(i, j).Shape.TextFrame.TextRange.Text
                Next j
            Next i
            
            shLeft = Sh.Left: shTop = Sh.Top
            shHeight = Sh.Height: shWidth = Sh.Width
            
            ' Delete the existing table
            table.Parent.Delete
            
            ' Create a new transposed table at the same position
            Set newTable = Slide.Shapes.AddTable(numRows:=numCols, NumColumns:=numRows, _
                Left:=shLeft, Top:=shTop, Width:=shWidth / numCols * numRows, _
                Height:=shHeight / numRows * numCols).table
            
            ' Populate the new table with the transposed data
            For i = 1 To numCols
                For j = 1 To numRows
                    newTable.Cell(i, j).Shape.TextFrame.TextRange.Text = tempArray(i, j)
                Next j
            Next i
            
            Exit Sub ' Transpose only the first table found
        End If
    Next Sh
    
    ' No table found
    MsgBox "The selected slide does not contain a table.", vbExclamation
End Sub

Now, the code should work but I do not know how changing the respective dimensions will affect the slide space, against the other existing shapes, if any...

Please, send some feedback after testing it.