在Powerpoint VBA中转置表格。

huangapple go评论62阅读模式
英文:

Transpose table in Powerpoint VBA

问题

我正在寻找一个按钮,可以在PowerPoint中一键转置表格,我尝试了几个脚本,但对我来说不起作用,下面是我尝试的内容,希望您能理解我在哪里出错,并期待您的帮助来纠正我。

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

    ' 检查是否选择了第一张幻灯片并且有一个表格
    If ActiveWindow.Selection.Type <> ppSelectionSlides Then
        MsgBox "请选择一张幻灯片。", vbExclamation
        Exit Sub
    End If

    Set slide = ActiveWindow.Selection.SlideRange(1)

    ' 检查幻灯片上是否有表格
    If slide.Shapes.Count = 0 Then
        MsgBox "所选幻灯片没有任何形状。", 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

            ' 创建一个临时数组来存储转置的表格数据
            ReDim tempArray(1 To numCols, 1 To numRows)

            ' 将表格数据转置到临时数组中
            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

            ' 删除现有的表格
            table.Delete

            ' 在相同位置创建一个新的转置表格
            Set newTable = slide.Shapes.AddTable(NumRows:=numCols, NumColumns:=numRows, Left:=shape.Left, Top:=shape.Top, Width:=shape.Height, Height:=shape.Width).Table

            ' 使用转置的数据填充新表格
            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 ' 仅转置找到的第一个表格
        End If
    Next shape

    ' 未找到表格
    MsgBox "所选幻灯片不包含表格。", vbExclamation
End Sub

这是您提供的VBA代码的翻译。

英文:

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
    
    &#39; Check if the first slide is selected and has a table
    If ActiveWindow.Selection.Type &lt;&gt; ppSelectionSlides Then
        MsgBox &quot;Please select a slide.&quot;, vbExclamation
        Exit Sub
    End If
    
    Set slide = ActiveWindow.Selection.SlideRange(1)
    
    &#39; Check if the first shape on the slide is a table
    If slide.Shapes.Count = 0 Then
        MsgBox &quot;The selected slide does not have any shapes.&quot;, 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
            
            &#39; Create a temporary array to store the transposed table data
            ReDim tempArray(1 To numCols, 1 To numRows)
            
            &#39; 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
            
            &#39; Delete the existing table
            table.Delete
            
            &#39; 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
            
            &#39; 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 &#39; Transpose only the first table found
        End If
    Next shape
    
    &#39; No table found
    MsgBox &quot;The selected slide does not contain a table.&quot;, vbExclamation
End Sub

答案1

得分: 2

你的代码中存在两个问题:1. 你尝试删除表格的方式是错误的,应该删除表格的父对象/形状。2. 在删除形状后,对它的引用会丢失。因此,你必须首先记住所涉及的形状的必要属性(Left、Top、Height 和 Width),然后在删除后使用它们:

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
    
    ' 检查是否选择了第一张幻灯片并且是否有表格
    If ActiveWindow.Selection.Type <> ppSelectionSlides Then
        MsgBox "请先选择一张幻灯片。", vbExclamation
        Exit Sub
    End If
    
    Set slide = ActiveWindow.Selection.SlideRange(1)
    
    ' 检查幻灯片上第一个形状是否是表格
    If slide.Shapes.Count = 0 Then
        MsgBox "所选幻灯片上没有任何形状。", 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
            
            ' 创建一个临时数组来存储转置后的表格数据
            ReDim tempArray(1 To numCols, 1 To numRows)
            
            ' 将表格数据转置到临时数组中
            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
            
            ' 删除现有的表格
            table.Parent.Delete
            
            ' 在相同位置创建一个新的转置表格
            Set newTable = slide.Shapes.AddTable(numRows:=numCols, NumColumns:=numRows, _
                Left:=shLeft, Top:=shTop, Width:=shWidth / numCols * numRows, _
                Height:=shHeight / numRows * numCols).table
            
            ' 用转置后的数据填充新表格
            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 ' 仅转置找到的第一个表格
        End If
    Next Sh
    
    ' 未找到表格
    MsgBox "所选幻灯片上不包含表格。", vbExclamation
End Sub

现在,这段代码应该可以工作了,但我不知道更改相应的维度会如何影响幻灯片空间,是否会影响其他已存在的形状... 请在测试后提供一些反馈。

英文:

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
    
    &#39; Check if the first slide is selected and has a table
    If ActiveWindow.Selection.Type &lt;&gt; ppSelectionSlides Then
        MsgBox &quot;Please select a slide.&quot;, vbExclamation
        Exit Sub
    End If
    
    Set slide = ActiveWindow.Selection.SlideRange(1)
    
    &#39; Check if the first Sh on the slide is a table
    If slide.Shapes.Count = 0 Then
        MsgBox &quot;The selected slide does not have any Shs.&quot;, 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
            
            &#39; Create a temporary array to store the transposed table data
            ReDim tempArray(1 To numCols, 1 To numRows)
            
            &#39; 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
            
            &#39; Delete the existing table
            table.Parent.Delete
            
            &#39; 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
            
            &#39; 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 &#39; Transpose only the first table found
        End If
    Next Sh
    
    &#39; No table found
    MsgBox &quot;The selected slide does not contain a table.&quot;, 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.

huangapple
  • 本文由 发表于 2023年7月27日 18:28:54
  • 转载请务必保留本文链接:https://go.coder-hub.com/76778838.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定