Question

在下面要讨论的代码中查找（HERE）。

如果在D列中未找到任何“活动”条件，是否可以设置错误消息？我尝试输入一个on error goto，但是当D列中没有“活动”项目时，它给了msgbox。但是，一旦有“活动”单元，它就会出错并且无法完成代码。

我确实使用了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

如果条件不匹配，则添加错误消息

1 个答案: