Excel vba形状粘贴不起作用答案

【问题标题】：Excel vba Shape Paste not workExcel vba形状粘贴不起作用
【发布时间】：2015-05-18 09:13:15
【问题描述】：

我试图将文本框从 sheet1 粘贴到 sheet2

Function footer()
Application.Volatile True
r = Application.Caller.Address
SheetName = Application.Caller.Parent.Name

    Select Case Range("Locale").Value
        Case "RU": boxx = Range("company").Value & Range("Locale")
        Case "EN": boxx = Range("company").Value & Range("Locale")
    End Select
Worksheets("Translations").Shapes(boxx).Copy
MsgBox Worksheets("Translations").Shapes(boxx).TextFrame.Characters.Text
ActiveSheet.Paste
End Function

Msgbox 看起来不错，但是粘贴功能什么也没做，我尝试了不同的方法

ActiveSheet.range("A1").Paste
ActiveSheet.range("A1").PasteSpecial
工作表(SheetName).Paste
工作表(SheetName).Range(r).Paste

一切都不起作用，工作表中什么也没有出现，有什么问题？

【问题讨论】：

如果您从单元格中调用此函数，它将不起作用。单元格中的 UDF 无法复制形状。
是的，它从单元格调用
那么它就不行了，就像我说的那样。不允许 UDF 这样做。我会发布一个解决方法

标签： vba excel

【解决方案1】：

虽然您无法复制和粘贴形状，但您可以添加新形状并从原始形状复制文本和格式 - 例如：

Function footer()
    Dim boxx                  As String
    Dim shpTo                 As Shape
    Dim shpFrom               As Shape

    Application.Volatile True

    Select Case Range("Locale").Value
        Case "RU": boxx = Range("company").Value & Range("Locale")
        Case "EN": boxx = Range("company").Value & Range("Locale")
    End Select
    Set shpFrom = Worksheets("Translations").Shapes(boxx)
    With Application.Caller
        Set shpTo = .Worksheet.Shapes.AddShape(shpFrom.AutoShapeType, .Left, .Top, shpFrom.Width, shpFrom.Height)
        shpTo.TextFrame.Characters.Text = shpFrom.TextFrame.Characters.Text
    End With
    shpFrom.PickUp
    shpTo.Apply
End Function

【讨论】：

谢谢，但我已经尝试过这种方式，在我看来它不会删除文本中的所有格式

【解决方案2】：

试试这个复制方法

ThisWorkbook.Sheets("Sheet1").Shapes.Range(Array(shpFrom.Name)).Select
Selection.Copy

【讨论】：