Добавить сообщение об ошибке, если критерии не совпадают

Question

Найдите (ЗДЕСЬ) в приведенном ниже коде для строки, о которой я говорю.

Можно ли настроить сообщение об ошибке, если не найдено ни одного критерия "Активно" в столбце D?Я попытался ввести on error goto, но он выдал msgbox, когда в столбце D не было «активных» проектов. Но как только появилась «активная» ячейка, она выдаст ошибку и не завершит код.

Я использовал Exit Sub и Resume, но все еще не работал.

Const cCrit As Variant = "D"      ' Criteria Column Letter/Number
Const cCols As String = "C:J"     ' Source/Target Data Columns
Const cFRsrc As Long = 15         ' Source First Row

Dim ws1 As Worksheet              ' Source Workbook
Dim ws2 As Worksheet              ' Target Workbook
Dim rng As Range                  ' Filter Range, Copy Range
Dim lRow As Long                  ' Last Row Number
Dim FRtgt As Long                 ' Target First Row
Dim Answer As VbMsgBoxResult      ' Message Box
Dim Error1 As VbMsgBoxResult      ' Message Box for Errors

' Create references to worksheets.
With ThisWorkbook
    Set ws1 = .Worksheets("Future Project Hopper")
    Set ws2 = .Worksheets("CPD-Carryover,Complete&Active")
End With

Answer = MsgBox("Do you want to run the Macro?", vbYesNo, "Run Macro")

If Answer <> vbYes Then Exit Sub

' In Source Worksheet
With ws1
    ' Clear any filters.
    .AutoFilterMode = False
    ' Calculate Last Row.
    lRow = .Cells(.Rows.Count, cCrit).End(xlUp).row
    ' Calculate Filter Column Range.
    Set rng = .Cells(cFRsrc, cCrit).Resize(lRow - cFRsrc + 1)
    ' Make an offset for the filter to start a row before (above) and
    ' end a row after (below).
    With rng.Offset(-1).Resize(lRow - cFRsrc + 3)
        ' Filter data in Criteria Column.
        .AutoFilter Field:=1, Criteria1:="Active"
    End With
    ' Create a reference to the Copy Range.
  **(HERE)**  Set rng = .Columns(cCols).Resize(rng.Rows.Count).Offset(cFRsrc - 1) _
            .SpecialCells(xlCellTypeVisible)

    ' Clear remaining filters.
    .AutoFilterMode = False

    End With

' Calculate Target First Row.
FRtgt = ws2.Cells(ws2.Rows.Count, cCrit).End(xlUp).row + 1
' Copy Range and paste to Target Worksheet and clear contents of future project hopper
rng.Copy
ws2.Columns(cCols).Resize(1).Offset(FRtgt - 1).PasteSpecial xlPasteValues
rng.Rows.ClearContents


Application.CutCopyMode = False

Answer 1

Дайте этому шанс:

On Error Resume Next
Set Rng = .Columns(cCols).Resize(Rng.Rows.Count).Offset(cFRsrc - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Rng Is Nothing Then
    MsgBox "No criteria found! Exiting sub"
    Exit Sub
End If