Question

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

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

    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

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

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

例如如果我在幻灯片4上运行宏，则.Left = AA和.Top = BB中的所有形状都将粘贴在幻灯片5中.Left = CC和.Top = 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，“为每个”故障排除帮助（与复制粘贴）

2 个答案: