时间戳

首页 > 解决方案 > 如果条件不匹配，则添加错误消息

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

问题描述

在下面的代码中寻找（这里）我正在谈论的行。

如果在 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

标签： excelvba

解决方案

试一试：

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

推荐阅读