在 Excel 中通过 VBA 复制和粘贴形状时出现 1004 错误答案

【问题标题】：1004 error when copying and pasting shapes via VBA in Excel在 Excel 中通过 VBA 复制和粘贴形状时出现 1004 错误
【发布时间】：2022-03-21 12:17:23
【问题描述】：

当我尝试在 Excel 中复制和粘贴形状时，我收到一条调试消息，告诉我有一个

1004 错误 - 图片类的复制方法失败

当我在宏中按继续时，它有效吗？我尝试添加一个Application.Wait(5) 语句来添加延迟，但同样的事情发生了。我尝试在Copy 和Paste 之间添加DoEvents，但没有帮助。

Public Sub PlotApprovals()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim strCountry As String
    Dim datEmergencyUseApproval As Date
    Dim rngSyringe As Range
    Dim intCountryCols As Integer
    Dim intColCount As Integer
    Dim shpCopy As Shape
    Dim shpPaste As Shape
    Dim intShapeIndex As Integer
    
    intCountryCols = 1
    intColCount = 4
    
    lngCol = 4
    
    DeleteShapes
    
    For intColCount = 1 To 4
        If intColCount = 1 Then
            lngCol = 4
        ElseIf intColCount = 2 Then
             lngCol = 9
        ElseIf intColCount = 2 Then
         lngCol = 14
        ElseIf intColCount = 2 Then
         lngCol = 19
        End If
        
        For lngRow = 3 To 42
            Set rngSyringe = shtDashboard.Cells(lngRow, lngCol + 1)
            strCountry = shtDashboard.Cells(lngRow, lngCol)
            datEmergencyUseApproval = Application.WorksheetFunction.VLookup(strCountry, shtData.Range("A:X"), 24, False)
            If datEmergencyUseApproval <> 0 Then
                Set shpCopy = shtDashboard.Shapes("syringeEmergencyUse")
                shpCopy.Copy
                shtDashboard.Paste
                intShapeIndex = idxLastShape("Dashboard")
                Set shpCopy = shtDashboard.Shapes(intShapeIndex)
                shpCopy.Name = "syringe"
                shpCopy.Left = rngSyringe.Left
                shpCopy.Top = rngSyringe.Top
            End If
        Next lngRow
    Next intColCount
End Sub




Public Sub DeleteShapes()

    Dim shp As Shape
    
    For Each shp In ActiveSheet.Shapes
        If shp.Name = "syringe" Then
            shp.Delete
        End If
    Next shp
End Sub


Function idxLastShape(shtName As String) As Long
    Dim sh As Shape
    For Each sh In Sheets(shtName).Shapes
        idxLastShape = idxLastShape + 1
    Next sh
End Function

---------更新-------------

如果主复制和粘贴逻辑如下更新，我现在会收到“对象形状复制失败”错误。它带我进入调试，如果我继续它工作。所以失败是在运行时，但是当我单步执行时它在调试模式下工作。

Set shpCopy = shtDashboard.Shapes("syringeEmergencyUse")
shpCopy.Select
shpCopy.Copy
rngSyringe.Select
shtDashboard.Paste
intShapeIndex = idxLastShape("Dashboard")
Set shpCopy = shtDashboard.Shapes(intShapeIndex)
shpCopy.Name = "syringe"
shpCopy.Left = rngSyringe.Left
shpCopy.Top = rngSyringe.Top
GreenCell rngCountry

【问题讨论】：

哪一行显示错误？确切的错误信息是什么？
粘贴 line.1004 - 图片类的复制方法失败

标签： excel vba

【解决方案1】：

当您shtDashboard.Paste 并且选择了一个形状而不是单元格时，就会出现此问题。确保在粘贴之前选择一个单元格：

shpCopy.Select
shpCopy.Copy
shtDashboard.Range("A1").Select 'select a cell to ensure no shape is selected
shtDashboard.Paste

【讨论】：

太棒了，谢谢。所以我想我想把它粘贴回自己
现在我得到方法“形状对象的复制失败”
@smackenzie 在复制之前确保.Select 形状。
为什么当我在调试中单步执行它时它可以工作，而不是在运行模式下？
如果我在进行复制之前执行 shpCopy.Select，仍然无法正常工作。我将我正在使用的新代码添加到原始问题中。我可以单步调试并运行它，正常执行时出现运行时错误。

【解决方案2】：

解决办法好像是在复制后加这个，一定是时间问题：

shp.Copy
Application.Wait(Now+TimeSerial(0,0,2))
DoEvents
rngSyringe.Select
ActiveSheet.Paste

【讨论】：