Excel VBA: 在相同位置复制和粘贴形状

Question

我想从一个工作表复制所有形状并将它们粘贴到另一个工作表的相同位置。形状可以是矩形标注或图片。

到目前为止，我知道如何遍历旧工作表中的所有形状：

Dim s As Shape For each s in Activesheet.Shapes ... Next

如何将形状复制并粘贴到另一个工作表中的相同位置，例如 Sheets("new")？

Answer 1

据我所知，没有特定的方法可以将它们全部复制。您可以尝试常规的 .Copy Destination:=... 方法，但我不确定这是否有效。

另一种方法是在新的 sheet 上生成一个与所需形状具有相同属性的新形状。当您循环遍历当前 sheet 上的形状时，您只需要创建具有所有相同属性的新形状对象。

最有效的方法（虽然这在一定程度上取决于您的意图）只是复制原始作品sheet，而不是生成新作品sheet。这会将所有形状（和其他数据）拉到新的 sheet，所有位置和属性都保持相同。如果您只需要单元格数据的形状和 none，您可以复制 sheet 然后添加 NewSheet.UsedRange.ClearContents 这将删除所有数据但保留格式不变。

Answer 2

下面的代码应该可以让你开始。请注意，我在代码中使用了内部 sheet 名称。（Sheet1 和 Sheet2。Project Explorer 中括号前的名称）

我使用了一些变通方法来避免使用选择：您需要先设置形状的名称，因为如果它仍然具有标准名称（例如 "Oval 3"），名称会更改（ "Oval 4")。最后你可以在两个 sheets 中恢复形状的原始名称。

Sub CopyShapes()

    Dim s As Shape
    Dim OriginalName As String

    For Each s In Sheet1.Shapes
        OriginalName = s.Name
        s.Name = "FixedName"
        s.Copy
        Sheet2.Paste
        Sheet2.Shapes("FixedName").Top = s.Top
        Sheet2.Shapes("FixedName").Left = s.Left
        s.Name = OriginalName
        Sheet2.Shapes("FixedName").Name = OriginalName
    Next s

End Sub

编辑： 调整代码以避免使用评论中要求的 Selection.

Excel VBA: 在相同位置复制和粘贴形状

Excel VBA: Copy and paste shapes at same position

excel

vba

shapes