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

1378
Markus

Мне любопытно 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
0
Вы уверены, что `detailinreview` существует? И что индекс нужной вам фигуры равен 1? Я почти уверен, что ваша вторая ошибка в том, что того, чего вы хотите, не существует, но затем вы проверяете, существует ли оно? Raystafarian 8 лет назад 0
Лист определенно существует. Он создан в "некотором другом коде". И я также использовал `ThisWorkbook.Worksheets (DETAILINTERVIEW) .Shapes (" MY_LOGO ")` раньше, вместо `Shapes (1)`. Но это привело к той же странной ошибке во время выполнения. Markus 8 лет назад 0
Пожалуйста, опубликуйте остальную часть вашего кода. Kyle 8 лет назад 1

1 ответ на вопрос

-1
Kyle

Использование 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

Похожие вопросы