错误处理完成后出现奇怪的错误行为

Question

我正在使用通过尝试命名并重定向错误直到找到有效名称来创建唯一表名的子文件夹。

子的作品，但在离开子，并试图在OLEOBJECT复选框来测试值后，它给了我，我以前被重定向错误 - 那就是除非我执行一些其他呼叫如ws.Activate或application.screenupdating = false 。我曾尝试在代码中的各个位置放置Err.Clear，但没有成功。

我很新的VBA（不到一个月的使用它），所以原谅我的明显错误。

我用Excel 2013年

运行此首先创建在Sheet1中的复选框，并与一个指定名称的新表：

Private Sub runfirst() 

    Dim cb1 As OLEObject 
    Dim ws As Worksheet 

    Sheet1.OLEObjects.Delete 
    Set cb1 = Sheet1.OLEObjects.Add(ClassType:="Forms.CheckBox.1") 
    cb1.Name = "CheckBox1" 
    cb1.Object.Caption = "Checkbox1" 

    Set ws = ThisWorkbook.Sheets.Add 
    ws.Name = "mysheet" 

End Sub 

主要代码：

Private Sub test1() 
    'This throws an error 
    Dim ws As Worksheet 

    Set ws = ThisWorkbook.Sheets.Add 
    NameWS rootname:="mysheet", ws:=ws 
    'ws.Activate 
    If Sheet1.CheckBox1.Value = True Then MsgBox "true" Else MsgBox "false" 

End Sub 

Private Sub test2() 
    ' This works fine 
    Dim ws As Worksheet 

    Set ws = ThisWorkbook.Sheets.Add 
    NameWS rootname:="mysheet", ws:=ws 
    ws.Activate 
    If Sheet1.CheckBox1.Value = True Then MsgBox "true" Else MsgBox "false" 

End Sub 


Private Sub NameWS(rootname As String, ws As Worksheet) 
    ' This sub tries to name the WS as rootname, if it fails, it increments a counter in the name. 

    Dim ctr As Long 
    ctr = 0 

    On Error GoTo Err1: 
    ws.Name = rootname 
    Exit Sub 

BaseNameTaken: 
    ctr = ctr + 1 
    On Error GoTo Err1: 
    ws.Name = rootname & " (" & ctr & ")" 
    ' If execution makes it to here it means that a valid name has been found 

    On Error GoTo 0 
    Exit Sub 

Err1: 
    If ctr > 99 Then Resume Fail ' Just to ensure we haven't created an infinite loop 
    Resume BaseNameTaken 

Fail: 
    ' Leave sub. Inability to name WS is not a critical error. 
    MsgBox "Failed to name worksheet after " & ctr & " tries. Excel default name used." 

End Sub 

Answer 1

它的设置Application.DisplayAlerts

的问题，你可能想要使用此功能

Private Sub NameWS(rootname As String, ws As Worksheet) 
    Dim ctr As Long 
    Application.DisplayAlerts = False 
    Do 
     On Error Resume Next 
     ws.name = rootname & IIf(ctr = 0, "", " (" & ctr & ")") 
     ctr = ctr + 1 
    Loop While Err > 0 
    Application.DisplayAlerts = True 
End Sub 

此外，该行：

If Sheet1.CheckBox1.Value = True Then MsgBox "true" Else MsgBox "false" 

可以简化为：

MsgBox Sheet1.CheckBox1.Value 

Answer 2

我不喜欢On Error Goto Label。我发现代码跳跃难以理解，难以正确理解。

下面的宏是我如何将代码，如例程。

首先，几点可能会有所帮助。

我有一个名为Resources的子文件夹“VBA”，“VBA Excel”和“VBA Outlook”。如果我使用VBA Word或VBA Access，我也会为它们设置子文件夹。每当我完成一个开发时，我会查看我的代码，以查找可能会再次使用的例程。如果例程是通用VBA，则将其作为文本文件保存在“VBA”中。按照你的日常工作，我将它保存为“NameWS .txt”文件夹“VBA Excel”中。

宏开始时会解释它的功能。如果这个宏很复杂，它也会概述它是如何实现它的目标的。当我在六个月或十二个月或五年的时间里观察宏观时，这可以帮助我。我有几年前写的宏，快速查看它是否对今天的问题有帮助。

最后，宏的历史的第一行。每次我更新宏时，我都会添加一个或两个说什么和为什么。

Private Sub NameWS(rootname As String, ws As Worksheet) 

    ' Attempt to rename worksheet ws as rootname. If successful, exit. 
    ' If unsuccessful, rename worksheet as rootname (N) where 
    ' N is the first number in the sequence 1, 2, 3 and so on such 
    ' that rootname (N) did not previously exist. 

    ' 7Nov16 Coded. 

    Dim ctr As Long 
    Dim NameCrnt As String 

    ' Try rootname first 
    On Error Resume Next 
    ws.Name = rootname 
    On Error GoTo 0 
    If ws.Name = rootname Then 
    ' Rename successful 
    Exit Sub 
    End If 

    ' rootnamne is use. Try rootname (1), rootname(2), etc, until 
    ' get successful rename. 
    ctr = 1 
    Do While True 
    NameCrnt = rootname & " (" & ctr & ")" 
    On Error Resume Next 
    ws.Name = NameCrnt 
    On Error GoTo 0 
    If ws.Name = NameCrnt Then 
     ' Rename successful 
     Exit Sub 
    End If 
    ctr = ctr + 1 
    Loop 

End Sub