如何在Excel VBA中粘贴形状且不取消选中目标单元格？

原代码问题 #

你提供的宏录制代码依赖大量Select操作，不仅效率低下，粘贴后还会选中新插入的形状，无法保留原活动单元格的选中状态：

Sub Print_Completed()

Application.ScreenUpdating = False

    Sheets("Saver").Select
    ActiveSheet.Shapes.Range(Array("Graphic 1")).Select
    Selection.Copy
    Sheets("Main").Select
    ActiveSheet.Paste
    
Application.ScreenUpdating = True

End Sub

优化解决方案 #

下面的代码既提升了运行效率，又能在粘贴形状后保持原目标单元格的选中状态：

Sub Print_Completed_Improved()
    Dim targetCell As Range
    Dim sourceShape As Shape
    
    Application.ScreenUpdating = False
    
    ' 提前记录Main工作表当前的活动单元格
    Set targetCell = ThisWorkbook.Worksheets("Main").ActiveCell
    ' 直接获取需要复制的形状对象，避免Select操作
    Set sourceShape = ThisWorkbook.Worksheets("Saver").Shapes("Graphic 1")
    
    ' 复制并粘贴形状到目标单元格位置
    sourceShape.Copy
    targetCell.PasteSpecial
    
    ' 重新选中原目标单元格
    targetCell.Select
    
    Application.ScreenUpdating = True
End Sub

核心改进点 #

• 移除冗余的Select操作：直接通过对象引用操作工作表和形状，减少Excel界面刷新开销，提升代码运行速度
• 保留原单元格选中状态：粘贴前用变量存储目标单元格，粘贴完成后重新选中该单元格，完全符合你的需求
• 精准定位粘贴位置：使用targetCell.PasteSpecial确保形状粘贴到目标单元格的左上角位置，和原代码效果一致

内容的提问来源于stack exchange，提问作者fatmstr97