英文:
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
' 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
答案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
' 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.
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论