VBA遍历工作表粘贴Logo至Rectangle A时陷入无限循环求助

问题根源 #

1. 始终锁定初始工作表：代码全程用ActiveSheet，没有切换到遍历的目标工作表ws，导致所有操作都在最初的活动表上重复执行，看起来像无限循环。
2. 多余的嵌套循环：内层For Each myshape In ws.Shapes完全没必要，会让程序在单个工作表内反复粘贴Logo，加剧了重复操作的问题。
3. 冗余的选择操作：VBA操作不需要先选中对象，直接通过对象引用操作更高效，还能避免选中状态带来的混乱。

修正后的代码（复制粘贴版） #

Dim sourceShape As Shape
Dim ws As Worksheet

' 从初始工作表复制目标Logo所在的矩形
Set sourceShape = ActiveSheet.Shapes("Rectangle A")
sourceShape.Copy

' 遍历工作簿中所有工作表
For Each ws In ActiveWorkbook.Worksheets
    ' 检查当前工作表是否存在名为"Rectangle A"的矩形
    On Error Resume Next ' 临时忽略错误，用于判断形状是否存在
    Dim targetShape As Shape
    Set targetShape = ws.Shapes("Rectangle A")
    On Error GoTo 0 ' 恢复默认错误处理
    
    ' 如果目标矩形存在，就粘贴Logo
    If Not targetShape Is Nothing Then
        ws.Activate ' 切换到目标工作表，确保粘贴位置正确
        targetShape.Select
        ActiveSheet.Paste
        Set targetShape = Nothing ' 释放对象占用的资源
    End If
Next ws

更高效的优化版（无需复制粘贴） #

如果只是要把Logo图片放到目标矩形里，可以直接复制形状的填充属性，避免剪贴板操作：

Dim sourceShape As Shape
Dim ws As Worksheet
Dim targetShape As Shape

Set sourceShape = ActiveSheet.Shapes("Rectangle A")

For Each ws In ActiveWorkbook.Worksheets
    On Error Resume Next
    Set targetShape = ws.Shapes("Rectangle A")
    On Error GoTo 0
    
    If Not targetShape Is Nothing Then
        ' 直接将源形状的图片填充复制到目标形状
        targetShape.Fill.UserPicture sourceShape.Fill.UserPicture
    End If
Next ws

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