Vba 在一个过程中有两个不同的错误处理程序

Question

我对 vba 中的两个单独的错误处理程序有疑问。两者都与查找两个单独的工作簿是否打开有关？

Sub ErrHandler()
    wbsource_name=ThisWorkbook.Worksheets("Sheet1").Range("A1").Value
    wbdest_name=ThisWorkbook.Worksheets("Sheet1").Range("B1").Value
    On Error GoTo Here
    Set wb_source=Workbooks(wbsource_name)
    Here:
    MsgBox "Open main file"
    Exit Sub

   'I want here to stop first err handler
   'The next file to be opened(or looked if is open)
   'So if first file is open, but second not. It again gives the first error handler message

    On Error GoTo 0
    On Error GoTo Here2
    Set wb_destination=Workbooks(wbdest_name)
    Here2:
    MsgBox "Open UPO file"

我已经使用 On error GoTo 0 来中和第一个错误处理程序，但不幸的是它不起作用。我也尝试过（代码行） On Error GoTo 0 使用 On error Resume Next...我该如何解决？任何想法......在一个子过程中使用两个不同的错误处理程序。先谢谢了

Answer 1

创建工作簿引用

Option Explicit

Sub TestOpenWorkbooks()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    Dim swbName As String: swbName = ws.Range("A1").Value
    Dim dwbName As String: dwbName = ws.Range("B1").Value
    
    On Error Resume Next
    Dim swb As Workbook: Set swb = Workbooks(swbName)
    On Error GoTo 0
    If swb Is Nothing Then
        MsgBox "Open main file."
        Exit Sub
    End If
    
    On Error Resume Next
    Dim dwb As Workbook: Set dwb = Workbooks(dwbName)
    On Error GoTo 0
    If dwb Is Nothing Then
        MsgBox "Open UPO file."
        Exit Sub
    End If

    MsgBox "Files open. Ready to continue."

End Sub

Sub TestOpenWorkbooksImproved()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    Dim swbName As String: swbName = ws.Range("A1").Value
    Dim dwbName As String: dwbName = ws.Range("B1").Value
    
    Dim wbPath As String: wbPath = "C:\Test\"
    
    ' This will work either way: open or not open.
    Dim swb As Workbook: Set swb = Workbooks.Open(wbPath & swbName)
    Dim dwb As Workbook: Set dwb = Workbooks.Open(wbPath & dwbName)

    MsgBox "Files open. Ready to continue."

End Sub

编辑

Sub TestOpenWorkbooksFunction()
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    Dim swbName As String: swbName = ws.Range("A1").Value
    Dim dwbName As String: dwbName = ws.Range("B1").Value
    
    Dim swb As Workbook: Set swb = RefWorkbook(swbName)
    If swb Is Nothing Then
        MsgBox "Open main file."
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = RefWorkbook(dwbName)
    If dwb Is Nothing Then
        MsgBox "Open UPO file."
        Exit Sub
    End If

    MsgBox "Files open. Ready to continue."

End Sub

Function RefWorkbook( _
    ByVal WorkbookName As String) _
As Workbook
    On Error Resume Next
    Set RefWorkbook = Workbooks(WorkbookName)
    On Error GoTo 0
End Function

Sub RefWorkbookTEST()
    Dim wb As Workbook: Set wb = RefWorkbook("?")
    If wb Is Nothing Then
        Debug.Print "Nope"
    Else
        Debug.Print wb.Name
    End If
End Sub

Answer 2

我更喜欢将可能产生错误的操作推送到单独的方法中（尤其是在主代码中重复该操作）。

Sub Tester()

    Dim wbSrc As Workbook, wbDest As Workbook, wbsource_name As String, wbdest_name As String

    wbsource_name = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value
    wbdest_name = ThisWorkbook.Worksheets("Sheet1").Range("B1").Value
    
    Set wbSrc = GetOpenWorkbook(wbsource_name, "Workbook '" & wbsource_name & "' must be open")
    If wbSrc Is Nothing Then Exit Sub
    
    Set wbDest = GetOpenWorkbook(wbdest_name, "Workbook '" & wbdest_name & "' must be open")
    If wbDest Is Nothing Then Exit Sub
      
End Sub

'Return an open workbook given its name, or Nothing if not found
'  Optional message `msgMissing` to show if not found
Function GetOpenWorkbook(wbName As String, Optional msgMissing As String = "") As Workbook
    On Error Resume Next
    Set GetOpenWorkbook = Workbooks(wbName)
    On Error GoTo 0
    If GetOpenWorkbook Is Nothing And Len(msgMissing) > 0 Then 
        MsgBox msgMissing
    End If
End Function