Question

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

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

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

如何将形状复制并粘贴到另一个工作表中的相同位置，比如Sheets（“new”）？

Answer 1

下面的代码可以帮到你。请注意，我在代码中使用了内部工作表名称。（Sheet1和Sheet2。项目浏览器中括号前的名称）

我使用了一些解决方法来避免使用选择：您需要首先设置形状的名称，因为如果它仍然具有标准名称（例如＆＃34; Oval 3＆＃34;）名称获取改变了（＆＃34;椭圆4＆＃34;）。最后，您可以在两个工作表中恢复形状的原始名称。

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.

Answer 2

据我所知，没有具体方法可以复制所有这些方法。您可以尝试常规.Copy Destination:=...方法，但我不肯定这会起作用。

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

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

Excel VBA：在同一位置复制和粘贴形状

2 个答案: