循环播放幻灯片和形状以复制表格

Question

我想：

循环浏览当前演示文稿中的所有幻灯片
遍历幻灯片中的形状
如果它是 table 且宽度 <410，则定位它，复制并定位副本。（我还应该检查幻灯片上是否还有另一个 table，但我无法让它工作。）
如果它是 table 并且宽度大于 880，那么简单地定位它。
重复直到完成。

复制和重新定位新形状时，代码进入无限循环。

Sub test()

    Dim sld As Slide
    Dim shp As Shape
    Dim sr As Series
    Dim chrt As Chart

    For Each sld In ActivePresentation.Slides
        For Each shp In sld.Shapes

            If shp.HasTable Then
                
                With shp
                        
                    MsgBox .Width
                        
                    If .Width < 410 Then
                        
                        MsgBox "<410"
                        
                        .Top = 170
                        .Left = 35
                        .Width = 409

                        .Duplicate

                        .Top = 170
                        .Left = 515
                        .Width = 409
                        
                    End If
                        
                    If .Width > 880 Then
                        
                        MsgBox ">880"
                        
                        .Top = 170
                        .Left = 35
                        .Width = 889
                        
                    End If

                End With
                
            End If
                
        Next shp
    Next sld
End Sub

Answer 1

如果您要在循环中向幻灯片添加形状，请避免循环 sld.Shapes。

一种方法是先将表收集到一个集合中，然后对其进行循环：

Sub test()

    Dim sld As Slide
    Dim shp As Shape, shp2 As Shape
    Dim sr As Series
    Dim chrt As Chart, col As Collection

    For Each sld In ActivePresentation.Slides
        'first collect any existing table(s) on the slide
        Set col = New Collection
        For Each shp In sld.Shapes
            If shp.HasTable Then col.Add shp
        Next shp
        
        'check what was found
        If col.Count = 1 Then
            Set shp = col(1)
            If shp.Width < 410 Then
                shp.Top = 170
                shp.Left = 35
                shp.Width = 409
                Set shp2 = shp.Duplicate.Item(1) 'duplicate and get a reference to the new table
                shp2.Top = 170
                shp2.Left = 515
                shp2.Width = 409
            ElseIf shp.Width > 880 Then
                shp.Top = 170
                shp.Left = 35
                shp.Width = 889
            End If
        ElseIf col.Count > 1 Then
            '>1 table found - what to do here?
        End If
    Next sld
End Sub

循环播放幻灯片和形状以复制表格

Loop through slides and shapes to duplicate tables

vba

resize

powerpoint

shapes