Excel VBA On Error Resume Next，选项正确但仍未恢复

Question

    我已经在 VBE 中检查了工具 > 选项 > 常规 > 错误捕获 - 我已将其设置为“类模块中断”和“未处理错误中断”，无论哪种方式它仍然会引发错误。报错就行了：

Set xlContacts = Workbooks(LocalContactsFilename)

    它会抛出一个错误，说下标超出范围，我知道这意味着在 Workbooks 集合中找不到索引，这个语句在这里是因为通常文件已经作为插件打开所以我可以得到通过此声明对其进行引用。它应该在此错误上恢复，因为如果文件未打开，我会打开它。

我注意到一件奇怪的事情——即使这行代码没有访问任何远程文件或网络，它只会在我与网络断开连接时抛出这个错误。如果我在连接到网络时打开工作簿，则不会引发此错误。

有谁之前经历过这个吗？当您的选项设置为仅在未处理的异常上停止但它仍然停止时？

Public Sub openContactsFile()
    On Error Resume Next
    Dim fso As New FileSystemObject
    Dim LocalContactsPath As String
    Dim LocalContactsFilename As String
    Dim LocalContactsShortFilename As String

    LocalContactsPath = wbMyCompanyWorkbook.Names("localContactsPath").RefersToRange.Value
    LocalContactsFilename = Mid(LocalContactsPath, (InStrRev(LocalContactsPath, "\") + 1))
    LocalContactsShortFilename = Mid(LocalContactsFilename, 1, (InStrRev(LocalContactsFilename, ".") - 1))

    'On Error Resume Next
    Application.ScreenUpdating = False

    If Not fso.FileExists(LocalContactsPath) Then
        If MsgBox("The contacts file is not available.  Click Yes to update the contacts now, or No to use the workbook without contact auto-fill capability.", vbYesNo, ThisWorkbook.NAME) = vbYes Then
            SyncContacts
        Else
            GoTo cancelParse
        End If
    End If
    If fso.FileExists(LocalContactsPath) Then
        On Error GoTo catch_no_remote_connection
        If fso.GetFile(LocalContactsPath).DateLastModified < fso.GetFile(wbMyCompanyWorkbook.Names("remoteContactsPath").RefersToRange.Value).DateLastModified Then
            If MsgBox("Your local contacts file appears to be out of date, would you like to download the latest contacts file?", vbYesNo Or vbQuestion, ThisWorkbook.NAME) = vbYes Then
                SyncContacts
            End If
        End If
catch_no_remote_connection:
        If Err.Number = 53 Then Err.CLEAR
        On Error Resume Next
        Set xlContacts = Workbooks(LocalContactsFilename)

        If xlContacts Is Nothing Then
            Set xlContacts = Workbooks.Open(LocalContactsPath, False, True)
        End If
        xlContacts.Sheets(1).Range("A1:CN2000").Sort Key1:=xlContacts.Sheets(1).Range("F2"), Order1:=xlAscending, Key2:=xlContacts.Sheets(1).Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    End If

    'hide the contacts from view or editing
    On Error Resume Next
    If Not Workbooks(LocalContactsFilename) Is Nothing Then xlContacts.IsAddin = True
    Err.CLEAR
    On Error GoTo 0
cancelParse:
    Application.ScreenUpdating = True
    Exit Sub
End Sub

提前感谢您对此的任何帮助！

Answer 1

我遇到过和你一样的问题（令人难以置信的令人沮丧，据我所知无法解释），但在不同的背景下。我发现最好的办法是找到解决方法。不要像你一样使用错误处理，而是使用它：

Dim wb As Workbook, _
    xlContacts As Workbook

For Each wb In Application.Workbooks
    If wb.Name = LocalContactsFilename Then
        Set xlContacts = wb
        Exit For
    End If
Next wb

If xlContacts Is Nothing Then
    Set xlContacts = Workbooks.Open(LocalContactsPath, False, True
End If

我更愿意按照你的方式编写代码，但似乎别无选择。

Answer 2

@蒂姆威廉姆斯
感谢您的回答-我认为 Err.CLEAR 会重置错误处理，但事实并非如此。下面的代码无论是否连接到网络都可以正常运行（我现在意识到这是问题的根源），问题是当它抛出文件未找到错误并转到catch_no_remote_connection时，没有恢复清除错误，所以我添加了这个来关闭错误处理块并重置处理程序：

    Resume post_err
post_err:

 功能代码：

Public Sub openContactsFile()
    On Error Resume Next
    Dim fso As New FileSystemObject
    Dim LocalContactsPath As String
    Dim LocalContactsFilename As String
    Dim LocalContactsShortFilename As String

    LocalContactsPath = wbMyCompanyWorkbook.Names("localContactsPath").RefersToRange.Value
    LocalContactsFilename = Mid(LocalContactsPath, (InStrRev(LocalContactsPath, "\") + 1))
    LocalContactsShortFilename = Mid(LocalContactsFilename, 1, (InStrRev(LocalContactsFilename, ".") - 1))

    Application.ScreenUpdating = False

    If Not fso.FileExists(LocalContactsPath) Then
        If MsgBox("The contacts file is not available.  Click Yes to update the contacts now, or No to use the workbook without contact auto-fill capability.", vbYesNo, ThisWorkbook.NAME) = vbYes Then
            SyncContacts
        Else
            GoTo cancelParse
        End If
    End If
    If fso.FileExists(LocalContactsPath) Then
        On Error GoTo catch_no_remote_connection
        If fso.GetFile(LocalContactsPath).DateLastModified < fso.GetFile(wbMyCompanyWorkbook.Names("remoteContactsPath").RefersToRange.Value).DateLastModified Then
            If MsgBox("Your local contacts file appears to be out of date, would you like to download the latest contacts file?", vbYesNo Or vbQuestion, ThisWorkbook.NAME) = vbYes Then
                SyncContacts
            End If
        End If
catch_no_remote_connection:
        'there is no network connection, clear the error and resume from here
        Err.CLEAR
        Resume post_err
post_err:
        On Error Resume Next
        'get reference to the workbook if it is already open
        Set xlContacts = Workbooks(LocalContactsFilename)

        If xlContacts Is Nothing Then
            'the workbook was not open, open it
            Set xlContacts = Workbooks.Open(LocalContactsPath, False, True)
        End If
        'sort contacts by company, name
        xlContacts.Sheets(1).Range("A1:CN2000").Sort Key1:=xlContacts.Sheets(1).Range("F2"), Order1:=xlAscending, Key2:=xlContacts.Sheets(1).Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
    End If

    'hide the contacts from view or editing by setting the workbook as an Addin
    On Error Resume Next
    If Not Workbooks(LocalContactsFilename) Is Nothing Then xlContacts.IsAddin = True
    Err.CLEAR
    On Error GoTo 0
cancelParse:
    Application.ScreenUpdating = True
    Exit Sub
End Sub

感谢大家花时间看这个！