Обработка ошибок в MS Excel VBA

Question

У меня небольшие проблемы с ошибками, возникающими в цикле в VBA. Во-первых, вот код, который я использую

dl = 20
For dnme = 1 To 3
Select Case dnme
Case 1
drnme = kt + " 90"
nme = "door90"
drnme1 = nme
Case 2
drnme = kt + " dec"
nme = "door70" 'decorative glazed'
Case 3
drnme = kt + " gl"
nme = "door80" 'plain glazed'
End Select

On Error GoTo ErrorHandler
Set sh = Worksheets("kitchen doors").Shapes(drnme) 'This line here is where the problem is'
sh.Copy
ActiveSheet.Paste
    Selection.ShapeRange.Name = nme
    Selection.ShapeRange.Top = 50
    Selection.ShapeRange.Left = dl
    Selection.ShapeRange.Width = 150
    Selection.ShapeRange.Height = 220
25
dl = dl + 160
Next dnme

 Exit Sub
ErrorHandler:

GoTo 25

Проблема в том, что когда он пытается получить доступ к форме, форма не всегда существует. Первый раз через цикл, это нормально. Это идет в ErrorHandler, и все работает хорошо. Во второй раз, когда он проходит и не может найти форму, появляется сообщение об ошибке «End / Debug». Я не могу понять, почему это не идет прямо к ErrorHandler. Есть предложения?

Answer 1

Я знаю, что это старый пост, но, возможно, это поможет кому-то еще. Используйте оригинальный код, но замените ErrorHandler: GoTo 25

с

ErrorHandler: Резюме 25

Answer 2

Прежде всего, у вас есть цикл for всего с 3 итерациями, и у вас есть переключатель для трех !!. почему вы не можете переместить свой общий код в новую функцию и вызывать ее трижды?

Более того, каждая ошибка имеет уникальный номер (в случае ошибок VBA, таких как Subscript вне диапазона и т. Д., Или описание, если это общий номер, такой как 1004, и других служебных ошибок). Вам нужно проверить номер ошибки, а затем решить, как поступить, если пропустить деталь или обойти ее.

Пожалуйста, пройдите через этот код ... Я переместил ваш comon-код в новую функцию, и в этой функции мы будем изменять размеры формы. Если фигура отсутствует, мы просто вернем false и перейдем к следующей фигуре.

'i am assuming you have defined drnme, nme as strings and d1 as integer
'if not please do so
Dim drnme As String, nme As String, d1 As Integer

dl = 20

drnme = kt + " 90"
nme = "door90"
If ResizeShape(drnme, nme, d1) Then
    d1 = d1 + 160
End If
'Just call 
'ResizeShape(drnme, nme, d1)
'd1 = d1 + 160
'If you don't care if the shape exists or not to increase d1
'in that case whether the function returns true or false d1 will be increased

drnme = kt + " dec"
nme = "door70" 'decorative glazed'
If ResizeShape(drnme, nme, d1) Then
    d1 = d1 + 160
End If

drnme = kt + " gl"
nme = "door80" 'plain glazed'
If ResizeShape(drnme, nme, d1) Then
    d1 = d1 + 160
End If

ActiveSheet.Shapes("Txtdoors").Select
Selection.Characters.Text = kt & ":   " & kttxt
Worksheets("kts close").Protect Password:="UPS"


End Sub

'resizes the shape passed in.
'if the shape does not exists then returns false.
'in that case you can skip incrementing d1 by 160

Public Function ResizeShape(drnme As String, nme As String, d1 As Integer) As Integer
On Error GoTo ErrorHandler
Dim sh As Shape
Set sh = Worksheets("kitchen doors").Shapes(drnme)
sh.Copy
ActiveSheet.Paste
Selection.ShapeRange.Name = nme
Selection.ShapeRange.Top = 50
Selection.ShapeRange.Left = dl
Selection.ShapeRange.Width = 150
Selection.ShapeRange.Height = 220
Exit Function
ErrorHandler:
'Err -2147024809 will be raised if the shape does not exists
'then just return false
'for the other errors you can examine the number and go back to next line or the same line
'by using Resume Next or Resume
'not GOTO!!
If Err.Number = -2147024809 Or Err.Description = "The item with the specified name wasn't found." Then
    ResizeShape = False
    Exit Function
End If
End Function

Answer 3

У вас не может быть двух разных ShapeRange объектов с одинаковым именем на одном и том же Worksheet. Есть ли вероятность, что один из существующих Shape копируемых объектов является членом ShapeRange с тем же именем, что и один из новых ShapeRange объектов, которые вы создаете?

Answer 4

OMG - вы не должны использовать gotos для входа и выхода из цикла !!!

Если вы хотите устранить ошибку самостоятельно, используйте что-то вроде этого:

''turn off error handling temporarily
On Error Resume Next

''code that may cause error

If Err.Number <> 0 then
  ''clear error
  Err.clear
  ''do stuff to handle error
End if

''resume error handling
On Error GoTo ErrorHandler

РЕДАКТИРОВАТЬ - попробуйте это - нет грязных GOTOS

  dl = 20
  For dnme = 1 To 3

    Select Case dnme
      Case 1
        drnme = kt + " 90"
        nme = "door90"
        drnme1 = nme

      Case 2
        drnme = kt + " dec"
        nme = "door70" 'decorative glazed'

      Case 3
        drnme = kt + " gl"
        nme = "door80" 'plain glazed'

    End Select

    'temporarily disable error handling'
    On Error Resume Next
    Set sh = Worksheets("kitchen doors").Shapes(drnme)

    'save error'
    ErrNum = Err.Number

    'reset error handling'
    On Error GoTo ErrorHandler

    If ErrNum = 0 Then

      sh.Copy

      ActiveSheet.Paste

      Selection.ShapeRange.Name = nme
      Selection.ShapeRange.Top = 50
      Selection.ShapeRange.Left = dl
      Selection.ShapeRange.Width = 150
      Selection.ShapeRange.Height = 220

    End If

    dl = dl + 160

  Next dnme

  ActiveSheet.Shapes("Txtdoors").Select
  Selection.Characters.Text = kt & ":   " & kttxt
  Worksheets("kts close").Protect Password:="UPS"


NormalExit:
  Exit Sub

ErrorHandler:
  MsgBox "Error Occurred: " & Err.Number & " - " & Err.Description
  Exit Sub

End Sub

Answer 5

Извините всех, я разработал решение. Очистка кода ошибки не работала, поэтому мне пришлось вместо этого использовать несколько GOTO, и теперь код работает (даже если это не самое элегантное решение). Ниже мой новый код:

dl = 20
For dnme = 1 To 3
BeginLoop:
Select Case dnme
Case 1
drnme = kt + " 90"
nme = "door90"
drnme1 = nme
Case 2
drnme = kt + " dec"
nme = "door70" 'decorative glazed'
Case 3
drnme = kt + " gl"
nme = "door80" 'plain glazed'
Case Else
GoTo EndLoop
End Select

On Error GoTo ErrorHandler
Set sh = Worksheets("kitchen doors").Shapes(drnme)
sh.Copy
ActiveSheet.Paste
    Selection.ShapeRange.Name = nme
    Selection.ShapeRange.Top = 50
    Selection.ShapeRange.Left = dl
    Selection.ShapeRange.Width = 150
    Selection.ShapeRange.Height = 220
25
dl = dl + 160
Next dnme

EndLoop:
     ActiveSheet.Shapes("Txtdoors").Select
    Selection.Characters.Text = kt & ":   " & kttxt
 Worksheets("kts close").Protect Password:="UPS"

 Exit Sub
ErrorHandler:
Err.Clear
dl = dl + 160
dnme = dnme + 1
Resume BeginLoop
End Sub