Нерегулярные ошибки времени выполнения в VBA с использованием функции копирования вставки фигуры

Мне любопытно 2 ошибки VBA во время выполнения. Любопытно, что 9 из 10 раз код работает отлично. Но время от времени появляется одна из 2 следующих ошибок времени выполнения:

Run-Time error '1004': Paste method of Picture object failed

Run-time error -214724809 (80070057): The index into the specified collection is out of bounds.

Я не мог определить какие-либо зависимости, когда он появится или не появится.

Вот что я делаю:

  1. Нажмите на кнопку в Excel, которая выполнит следующие шаги через VBA
  2. Создайте новый лист 'Detailinterview'
  3. Скопируйте логотип с листа "данные"
  4. Вставьте его на лист "Detailinterview"

Это мой код

Public Const DATA = "Data"
Public Const DETAILINTERVIEW = "Detailinterview"

Public Sub DoMagic()
  Dim logo As Shape

  'Some other code

  For Each logo In Sheets(DATA).Shapes
    If logo.Name = "MY_LOGO" Then
        logo.Copy
        Sheets(DETAILINTERVIEW).Pictures.Paste ' runtime error 1004
    End If
  Next

  ' Hint: Sheet DETAILINTERVIEW contains only 1 shape: MY_LOGO
  Set logo = Worksheets(DETAILINTERVIEW).Shapes(1) 'runtime error -214724809 
  If Not logo Is Nothing Then
    logo.IncrementLeft 580
    logo.IncrementTop 4
  End If
End Sub

Почему сбой VBA? Почему это только время от времени сбой? Как я могу это исправить?

Заранее спасибо!

В соответствии с просьбой здесь остальная часть кода:

Public Const DATA = "Data"
Public Const DETAILINTERVIEW = "Detailinterview"

Public Sub DoMagic()
    Dim logo As Shape
    Dim i As Long
    Dim sheetExists As Boolean

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    For i = 1 To Sheets.Count
        If Sheets(i).Name = DETAILINTERVIEW Then
          sheetExists = True
          Debug.Print MsgBox("A worksheet 'Detailinterview' exists already!", vbOKOnly)  
          Exit Sub
        End If
    Next i

    Worksheets("Datenblatt_Template").Copy after:=Worksheets(QUESTION_SELECTION)
    Worksheets("Datenblatt_Template (2)").Visible = True
    Worksheets("Datenblatt_Template (2)").Activate
    ActiveSheet.Name = DETAILINTERVIEW
    Worksheets(DETAILINTERVIEW).Columns("I:I").ColumnWidth = 1
    Worksheets(DETAILINTERVIEW).Columns("K:K").ColumnWidth = 33
    Worksheets(DETAILINTERVIEW).Columns("M:M").ColumnWidth = 17
    Worksheets(DETAILINTERVIEW).Columns("O:O").ColumnWidth = 3

    ActiveWindow.DisplayGridlines = False
    ActiveWindow.DisplayHeadings = False
    ThisWorkbook.Worksheets(DETAILINTERVIEW).Range("A:H").EntireColumn.Hidden = True

    ThisWorkbook.Worksheets("Templates").Range("T_HEADER").Copy
    ThisWorkbook.Worksheets(DETAILINTERVIEW).Activate
    ThisWorkbook.Worksheets(DETAILINTERVIEW).Rows("1:1").Select
    ThisWorkbook.ActiveSheet.Paste

    ThisWorkbook.Worksheets("Templates").Range("T_MASTER_HEADER").Copy
    ThisWorkbook.Worksheets(DETAILINTERVIEW).Activate
    ThisWorkbook.Worksheets(DETAILINTERVIEW).Rows("2:2").Select
    ThisWorkbook.ActiveSheet.Paste

    Worksheets(DETAILINTERVIEW).Range("J2").Value = Range(START & "!C20") & " - " & Range(START & "!C21") & " - " & Range(START & "!C22")

    For Each logo In Sheets(DATA).Shapes
        If logo.Name = "MY_LOGO" Then
             logo.Copy
             Sheets(DETAILINTERVIEW).Pictures.Paste ' runtime error 1004
        End If
    Next

    ' Hint: Sheet DETAILINTERVIEW contains only 1 shape: MY_LOGO
    Set logo = Worksheets(DETAILINTERVIEW).Shapes(1) 'runtime error -214724809 
    If Not logo Is Nothing Then
        logo.IncrementLeft 580
        logo.IncrementTop 4
    End If

    ' Some more Magic
End Sub
Источник

1 ответ

С помощью Select, Activate и т.д. это опасно. Вы должны вместо этого явно квалифицировать свои объекты с их родителями. Ex.

Sheets(1).Range("A1").value = 1

Лучше, чем

Sheets(1).Activate
Range("A1").Select
Selection.Value = 1

Я немного почистил ваш код:

Option Explicit

Public Const DATA = "Data"
Public Const DETAILINTERVIEW = "Detailinterview"

Public Sub DoMagic()
    Dim logo As Shape
    Dim i As Long

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    For i = 1 To Sheets.Count
        If Sheets(i).Name = DETAILINTERVIEW Then
          Debug.Print MsgBox("A worksheet " & DETAILINTERVIEW & " exists already!", vbOKOnly)
          Exit Sub
        End If
    Next i

Dim ws As Worksheet
With ThisWorkbook
    .Worksheets("Datenblatt_Template").Copy after:=.Worksheets(.Worksheets.Count)
    Set ws = .Worksheets(.Worksheets.Count)
End With
With ws
    .Name = DETAILINTERVIEW
    .Columns("I:I").ColumnWidth = 1
    .Columns("K:K").ColumnWidth = 33
    .Columns("M:M").ColumnWidth = 17
    .Columns("O:O").ColumnWidth = 3

    ActiveWindow.DisplayGridlines = False
    ActiveWindow.DisplayHeadings = False
    .Range("A:H").EntireColumn.Hidden = True

    ThisWorkbook.Worksheets("Templates").Range("T_HEADER").Copy Destination:=.Range("A1")
    ThisWorkbook.Worksheets("Templates").Range("T_MASTER_HEADER").Copy Destination:=.Range("A2")

    '***************************
    'I can't get the next line to run because Start is uninitialized 
    '.Range("J2").Value = Range(Start & "!C20") & " - " & Range(Start & "!C21") & " - " & Range(Start & "!C22")
    '****************************

    For Each logo In Sheets(DATA).Shapes
        If logo.Name = "MY_LOGO" Then
             logo.Copy
             .Pictures.Paste
             .Shapes(1).IncrementLeft 580
             .Shapes(1).IncrementTop 4
             Exit For
        End If
    Next
    If .Shapes.Count < 1 Then Debug.Print "Logo not found"
End With
    ' Some more Magic
End Sub
Источник
Другие вопросы по тегам