VBA错误处理转到下一个循环而不是恢复

Question

当导入选项卡中没有文件路径时，此代码会产生错误。因此，我包含On Error Resume Next 以便运行下一个循环。但是，在On Error Resume Next 之后，代码继续运行复制操作，这弄乱了我要复制到的选项卡。

我确定解决方案是 On Error 代码应该进入下一个循环而不是继续操作。有人对如何更改错误处理来做到这一点有任何意见吗？

Sub ImportBS()

Dim filePath As String
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Dim Cell As Range
Dim i As Integer
Dim k As Integer
Dim Lastrow As Long


'SourceWb - Workbook were data is copied from
'TargetWb - Workbook were data is copied to and links are stored

Application.ScreenUpdating = False

Set TargetWb = Application.Workbooks("APC Refi Tracker.xlsb")
Lastrow = TargetWb.Sheets("Import").Range("F100").End(xlUp).Row - 6


    For k = 1 To Lastrow
    

        filePath = TargetWb.Sheets("Import").Range("F" & 6 + k).Value
        Set SourceWb = Workbooks.Open(filePath)
    
    On Error Resume Next
        Range("A1").CurrentRegion.Copy
        TargetWb.Sheets("Balance Sheet Drop").Range("D" & 2 + (k - 1) * 149).PasteSpecial Paste:=xlPasteValues
        Range("A1").Copy
        Application.CutCopyMode = False
        SourceWb.Close

    Next

Application.ScreenUpdating = True

Worksheets("Import").Activate

    MsgBox "All done!"

End Sub

Answer 1

我会以不同的方式做这件事。我会使用Dir function 检查路径，然后决定要做什么。这是一个例子

For k = 1 To Lastrow
    filePath = TargetWb.Sheets("Import").Range("F" & 6 + k).Value
    
    '~~> Check if the path is valid
    If Not Dir(filePath, vbNormal) = vbNullString Then
        Set SourceWb = Workbooks.Open(filePath)
        
        '
        '~~> Rest of your code
        '
    End If
Next

Answer 2

导入数据

快速修复

For k = 1 To Lastrow
    filePath = TargetWb.Sheets("Import").Range("F" & 6 + k).Value
    Set SourceWb = Nothing
    On Error Resume Next
    Set SourceWb = Workbooks.Open(filePath)
    On Error GoTo 0
    If Not SourceWb Is Nothing Then
        Range("A1").CurrentRegion.Copy
        TargetWb.Sheets("Balance Sheet Drop").Range("D" & 2 + (k - 1) * 149).PasteSpecial Paste:=xlPasteValues
        Range("A1").Copy
        Application.CutCopyMode = False
        SourceWb.Close
    'Else ' File not found.
    End If
Next

改进

• 未测试。
• 在使用代码之前调整（检查）常量部分中的值。

---

Option Explicit

Sub ImportBS()

    ' Destination Read
    Const rName As String = "Import" ' where file paths are stored.
    Const rFirstRow As Long = 7
    Const rCol As Variant = "F" ' or 6
    ' Destination Write
    Const wName As String = "Balance Sheet Drop" ' where data is copied to.
    Const wFirstCell As String = "D2"
    Const wRowOffset As Long = 149
    ' Source
    Const srcID As Variant = "Sheet1" ' or e.g. 1 ' where data is copied from.
    Const srcFirstCell As String = "A1"
    
    ' Define Destination Worksheets.
    ' Note that if the workbook "APC Refi Tracker.xlsb" contains this
    ' code, you should use 'Set dstWB = ThisWorkbook' instead which would
    ' make the code more readable, but would also allow you to change
    ' the workbook's name and the code would still work.
    Dim dstWB As Workbook: Set dstWB = Workbooks("APC Refi Tracker.xlsb")
    Dim wsR As Worksheet: Set wsR = dstWB.Worksheets(rName)
    Dim wsW As Worksheet: Set wsW = dstWB.Worksheets(wName)
    
    ' Define Last Row in Destination Read Worksheet.
    Dim rLastRow As Long
    With dstWB.Worksheets(rName)
        rLastRow = .Cells(.Rows.Count, rCol).End(xlUp).Row
    End With
    
    ' Declare additional variables to use in the upcoming loop.
    Dim srcFilePath As String  ' Source File Path
    Dim srcWB As Workbook      ' Source Workbook
    Dim rng As Range           ' Source Range
    Dim i As Long              ' Destination Read Worksheet Rows Counter
    Dim k As Long              ' Destination Write Worksheet Write Counter
    
    Application.ScreenUpdating = False
    
    ' Loop through rows of Destination Read Worksheet
    ' (or loop through Source Workbooks).
    For i = rFirstRow To rLastRow
        ' Read Current Source File Path from Destination Read Worksheet.
        srcFilePath = wsR.Cells(i, rCol).Value
        ' Attempt to open Current Source Workbook.
        Set srcWB = Nothing
        On Error Resume Next
        Set srcWB = Workbooks.Open(srcFilePath)
        On Error GoTo 0
        ' If Current Source Workbook was opened...
        If Not srcWB Is Nothing Then
            ' Define Source Range.
            Set rng = srcWB.Worksheets(srcID).Range(srcFirstCell).CurrentRegion
            ' Define Destination First Cell Range.
            k = k + 1
            ' If a worksheet could not be opened and you want to skip
            ' the 149 lines then replace 'k - 1' with 'i - rFirstRow'
            ' in the following line.
            With wsW.Range(wFirstCell).Offset((k - 1) * wRowOffset)
                ' Write values from Source Range to Destination Range.
                .Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
            End With
            ' Close Source Workbook.
            srcWB.Close SaveChanges:=False
        'Else ' Current Source Workbook was not found.
        End If
    Next
    ' Note that there has been no change of the 'Selection' in any
    ' of the worksheets i.e. what was active at the beginning is still active.
       
    ' Save Destination Workbook.
    'dstWB.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Data sets copied    : " & k & vbLf _
        & "Data sets not copied: " & i - rFirstRow - k, vbInformation, "Success"

End Sub

Answer 3

编辑：更正代码

试试这个代码（感谢super-symmetry 的编辑，他也链接到this post）：

Sub ImportBS()
    
    Dim filePath As String
    Dim SourceWb As Workbook
    Dim TargetWb As Workbook
    Dim Cell As Range
    Dim i As Integer
    Dim k As Integer
    Dim Lastrow As Long
    
    
    'SourceWb - Workbook were data is copied from
    'TargetWb - Workbook were data is copied to and links are stored
    
    Application.ScreenUpdating = False
    
    Set TargetWb = Application.Workbooks("APC Refi Tracker.xlsb")
    Lastrow = TargetWb.Sheets("Import").Range("F100").End(xlUp).Row - 6
    
    On Error Resume Next
    
    For k = 1 To Lastrow
        
        
        filePath = TargetWb.Sheets("Import").Range("F" & 6 + k).Value
        
        Set SourceWb = Workbooks.Open(filePath)
        
        If Err <> 0 Then GoTo Error_Handler
        
        Range("A1").CurrentRegion.Copy
        TargetWb.Sheets("Balance Sheet Drop").Range("D" & 2 + (k - 1) * 149).PasteSpecial Paste:=xlPasteValues
        Range("A1").Copy
        Application.CutCopyMode = False
        SourceWb.Close
Leap:
    Next
    
    On Error GoTo -1
    
    Exit Sub
    
    Error_Handler:
    Err.Clear
    GoTo Leap
    
End Sub    

---

第一个（错误的）答案：

如果你想在出错的情况下跳过部分代码，你可以使用这样的东西：

    For k = 1 To Lastrow
    

        filePath = TargetWb.Sheets("Import").Range("F" & 6 + k).Value
        Set SourceWb = Workbooks.Open(filePath)
    
    On Error GoTo Leap
        Range("A1").CurrentRegion.Copy
        TargetWb.Sheets("Balance Sheet Drop").Range("D" & 2 + (k - 1) * 149).PasteSpecial Paste:=xlPasteValues
        Range("A1").Copy
        Application.CutCopyMode = False
        SourceWb.Close
Leap:
    Next

我想错误应该出现在Set SourceWb = Workbooks.Open(filePath) 行。在这种情况下，您可能应该将行 On Error GoTo Leap 放在 for 的开头之前；这样，如果列表的第一个为空，它将跳转到下一个单元格。我还建议在 for 结束后放置 On Error GoTo -1。像这样：

    On Error GoTo Leap
    
    For k = 1 To Lastrow
    

        filePath = TargetWb.Sheets("Import").Range("F" & 6 + k).Value
        Set SourceWb = Workbooks.Open(filePath)
        
        Range("A1").CurrentRegion.Copy
        TargetWb.Sheets("Balance Sheet Drop").Range("D" & 2 + (k - 1) * 149).PasteSpecial Paste:=xlPasteValues
        Range("A1").Copy
        Application.CutCopyMode = False
        SourceWb.Close
Leap:
    Next
    
    On Error GoTo -1

Answer 4

试试这个：

For k = 1 To Lastrow
    filePath = TargetWb.Sheets("Import").Range("F" & 6 + k).Value
    Set SourceWb = Workbooks.Open(filePath)

    On Error Resume Next
    Range("A1").CurrentRegion.Copy
    If Err <> 0 Then GoTo ContinuationPoint
    On Error GoTo 0
    TargetWb.Sheets("Balance Sheet Drop").Range("D" & 2 + (k - 1) * 149).PasteSpecial 
    Paste:=xlPasteValues
    Range("A1").Copy
    Application.CutCopyMode = False
    SourceWb.Close

ContinuationPoint:
    On Error GoTo 0
Next

注意两点。我在那里添加了两次On Error GoTo 0。当您使用On Error Resume Next 时，您实际上已经关闭了错误处理。这现在将其重新打开。如果您在尝试复制时遇到错误，那么它将跳转到ContinuationPoint（您可以将其重命名为您想要的任何名称）。无论哪种方式，我们都会重新打开错误处理。