MS Excel VBA 中的错误处理

Error handling in MS Excel VBA

提问by a_m0d

I am having a bit of trouble with errors occurring in a loop in VBA. First, here is the code I am using

我在 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

The problem is that when it tries to access the shape, the shape doesn't always exist. The first time through the loop, this is fine. It goes to the ErrorHandler and everything works good. The second time it goes through and can't find the shape, it comes up with the "End/Debug" error box. I can't work out why it doesn't just go straight to the ErrorHandler. Any suggestions?

问题是当它尝试访问形状时，形状并不总是存在。第一次通过循环，这很好。它转到 ErrorHandler 并且一切正常。第二次通过但找不到形状时，它会出现“结束/调试”错误框。我不明白为什么它不直接进入 ErrorHandler。有什么建议？

回答by Adarsha

First of all you have a for loop with only 3 iterations, and you have a switch case for three!!. why can't you move your common code to a new function and call it thrice?

首先，您有一个只有 3 次迭代的 for 循环，并且您有一个 3 次的 switch 案例！！。为什么不能将公共代码移动到新函数并调用三次？

And more over each error has a unique number (incase of VBA errors like Subscript out of range etc, or a description if its a generic number like 1004, and other office errors). You need to check the error number, then decide how to proceed, if to skip the part or work around.

而且每个错误都有一个唯一的编号（以防 VBA 错误，例如下标超出范围等，或者如果它是通用编号，例如 1004 和其他办公室错误，则说明）。您需要检查错误编号，然后决定如何继续、跳过该部分还是变通。

Please go through this code..I have moved your comon code to a new function, and in that function we will be resizing the shape. If the shape is missing then we will just return false, and move to next shape.

请仔细阅读此代码..我已将您的通用代码移至一个新函数，在该函数中，我们将调整形状的大小。如果形状丢失，那么我们将只返回 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

回答by Adarsha

I know this is an old post, but perhaps this will help someone else. Use the original code but replace ErrorHandler: GoTo 25

我知道这是一个旧帖子，但也许这对其他人有帮助。使用原始代码但替换 ErrorHandler: GoTo 25

with

和

ErrorHandler: Resume 25

错误处理程序：恢复 25

回答by a_m0d

Sorry everyone, I have worked out asolution. Clearing the error code didn't work, so I had to use a number of GOTOs instead, and now the code works (even if it isn't the most elegant solution). Below is my new code:

对不起大家，我已经找到了解决方案。清除错误代码不起作用，所以我不得不改用一些 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

回答by barrowc

You can't have two different ShapeRangeobjects with the same name on the same Worksheet. Is there a chance that one of the existing Shapeobjects that gets copied is a member of a ShapeRangewith the same name as one of the new ShapeRangeobjects that you are creating?

您不能ShapeRange在同一个Worksheet. Shape被复制的现有对象之一是否有可能是ShapeRange与ShapeRange您正在创建的新对象之一同名的成员？

回答by DJ.

OMG - you should not be using gotos to get in and out of a loop!!!

OMG - 你不应该使用 goto 进入和退出循环！！！

If you want to handle an error yourself you use something like this:

如果你想自己处理一个错误，你可以使用这样的方法：

''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

EDIT - try this - no messy GOTOS

编辑 - 试试这个 -没有凌乱的 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