PowerPoint VBA、"For each" 故障排除帮助（复制粘贴）

Question

我正在尝试循环复制形状，然后将其粘贴到下一张幻灯片。

我有 20 张幻灯片，其中 19 张在坐标 .Left = AA 和 .Top = BB 处有一个形状（实际上是一组形状，文本框，imgs 等）。

    Dim Sld As Slide
    Dim Shp As Shape

For Each Shp In Sld.Shapes
        With Shp
            If .Type = msoGroup _
                And .Left = AA _
                And .Top = BB _
                Then
                    .Cut

                With ActivePresentation.Slides(ActiveWindow.Selection.SlideRange.SlideIndex + 1)
                    .Shapes.Paste
                    .Left = CC
                    .Top = DD
                End With
            End If
        End With
    Next
Next Sld

这是我当前的代码，我遇到的问题是它将剪切并粘贴所有形状，但不会出现在首次复制形状的幻灯片之后的下一张幻灯片中。

它会将它们全部粘贴到我运行宏时所在位置的下一张幻灯片中。

例如，如果我在幻灯片 4 上并且我运行宏，则 .Left = AA 和 .Top = BB 中的所有形状将粘贴到幻灯片 5 中的 .Left = CC 和 .顶 = DD

我想要的是如果形状是在幻灯片 1 中剪切的，我希望将其粘贴到幻灯片 2 中的 .left = CC 和 .Top = DD。如果形状在幻灯片 2 中，我希望将其粘贴到幻灯片 3 中的 .left = CC 和 .Top = DD。等等。

提前感谢您的帮助。我已经坚持了一个多星期了。

Answer 1

这个工作（测试）示例有帮助吗？

Option Explicit

Const AA = 0
Const BB = 0
Const CC = 100
Const DD = 100

Sub MoveShapesBetweenSlides()
  Dim Sld As Slide
  Dim Shp As Shape
  For Each Sld In ActivePresentation.Slides
    For Each Shp In Sld.Shapes
      With Shp
        If .Type = msoGroup And .Left = AA And .Top = BB Then
          .Cut
          ' Create an index to the next slide
          Dim lNextSld As Long
          If Sld.SlideIndex = ActivePresentation.Slides.Count Then
            lNextSld = 1
          Else
            lNextSld = Sld.SlideIndex + 1
          End If
          ' Paste the shape from the previous slide to the next slide and reposition it
          With ActivePresentation.Slides(lNextSld)
            With .Shapes.Paste
              .Left = CC
              .Top = DD
            End With
          End With
        End If
      End With
    Next Shp
  Next Sld
End Sub

Answer 2

以下剪切和粘贴形状并重新定位它们 - 从倒数第二张幻灯片开始，以免剪切刚刚粘贴的形状：

Sub MyTestSub()
    Const OLD_DISTANCE_A As Long = 10
    Const OLD_DISTANCE_B As Long = 10
    Const NEW_DISTANCE_C As Long = 100
    Const NEW_DISTANCE_D As Long = 100

    Dim oSld As Slide
    Dim oShp As Shape
    Dim oShpRng As ShapeRange
    Dim lCurrentSlideIndex As Long

    '***** go through all slides except the last one - start from the next to last
    For lCurrentSlideIndex = ActivePresentation.Slides.Count - 1 To 1 Step -1
        Set oSld = ActivePresentation.Slides(lCurrentSlideIndex)

        For Each oShp In oSld.Shapes
            '***** is it in the position we are interested in?
            If oShp.Left = OLD_DISTANCE_A And oShp.Top = OLD_DISTANCE_B Then
                oShp.Cut

                '***** paste on slide + 1 (without checking that it exists!)
                Set oShpRng = ActivePresentation.Slides(oSld.SlideIndex + 1).Shapes.Paste

                '***** set new position
                oShpRng.Left = NEW_DISTANCE_C
                oShpRng.Top = NEW_DISTANCE_D
            End If
        Next oShp
    Next lCurrentSlideIndex
End Sub

PowerPoint VBA、"For each" 故障排除帮助（复制粘贴）

PowerPoint VBA, "For each" troubleshooting help (with copy pasting)

powerpoint

vba

loops

shapes