Excel VBA图片粘贴至错误工作表问题求助

你遇到的问题是Excel VBA中常见的粘贴上下文冲突：即便指定了目标工作表su，但如果粘贴操作执行时Excel的活动工作表并非su，粘贴内容就可能被错误放入当前激活的表格。另外你的重试循环存在变量初始化漏洞，会导致后续图表的重试逻辑直接失效。

以下是具体修复步骤：

1. 强制锁定目标工作表上下文 #

在执行粘贴前先激活su工作表，确保Excel的粘贴操作锁定到目标表：

su.Activate
su.Paste su.Cells(k, l)

2. 重置重试计数器 #

每次处理新图表前将x重置为0，否则第一次循环后x会保留为20，后续图表直接跳过重试逻辑：

' 在For Each Cht循环内开头添加
x = 0

3. 优化粘贴操作（可选但稳定性更高） #

用Shapes.Paste替代直接Paste，能更精准控制图片位置，避免上下文干扰：

su.Activate
su.Cells(k, l).Select
su.Shapes.Paste

4. 关闭屏幕更新减少干扰 #

在代码开头关闭屏幕更新，降低Excel界面操作对VBA执行的影响，结束后恢复：

' 代码开头
Application.ScreenUpdating = False

' 代码末尾
Application.ScreenUpdating = True

修复后的完整代码 #

Sub chartCopy(seq)
Dim ua As Worksheet, udc As Worksheet, wa As Worksheet, wdc As Worksheet, su As Worksheet
Dim wb As Workbook
Dim lastSheet As Integer
Dim Cht As ChartObject
Dim k As Integer
Dim l As Integer
Dim j As Integer
Dim x As Integer
Set wb = ThisWorkbook
Set ua = wb.Worksheets("Unweighted Analysis")
Set udc = wb.Worksheets("Unweighted Data Checks")
Set wa = wb.Worksheets("Weighted Analysis")
Set wdc = wb.Worksheets("Weighted Data Checks")
Set su = wb.Worksheets("Summary Page")

Application.ScreenUpdating = False ' 关闭屏幕更新

k = 15
l = 1 + (seq - 1) * 11
    
j = 0

If seq <> 4 Then
    lastSheet = 6
Else
    lastSheet = 4
End If
For i = 3 To lastSheet
    For Each Cht In wb.Worksheets(i).ChartObjects
        Debug.Print Cht.Name
        x = 0 ' 重置重试计数器
        If i = 3 Then
            Cht.Chart.Axes(xlCategory).MinimumScale = ua.Range("DF16").Value
        ElseIf i = 5 Then
            Cht.Chart.Axes(xlCategory).MinimumScale = wa.Range("DG16").Value
        End If
        
        Application.CutCopyMode = False
        Cht.CopyPicture
        
        Do While x < 20
            On Error Resume Next
            su.Activate ' 激活目标工作表
            su.Paste su.Cells(k, l)
            If Err.Number <> 0 Then
                Debug.Print "Paste failed", x, Err.Number, Err.Description
                DoEvents
                x = x + 1
            Else
                Exit Do
            End If
            On Error GoTo 0
            x = x + 1
        Loop
        k = k + 25
        j = j + 1
    Next Cht
    If i = 4 Then
        k = k + 10
    End If
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True ' 恢复屏幕更新

Call sizeImg

ua.Range("F3:K6").Copy
su.Cells(4, l).PasteSpecial Paste:=xlPasteValues
If seq <> 4 Then
    wa.Range("F3:K6").Copy
    su.Cells(141, l).PasteSpecial Paste:=xlPasteValues
End If

End Sub

额外提醒：原代码变量声明存在隐患，Dim ua, udc, wa, wdc, su As Worksheet仅su为Worksheet类型，其余均为Variant，修复后的代码已修正此问题。

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