excel数据库函数结合vba，如果没有记录怎么办？

Question

我正在使用excel的数据库功能。见示例图像

我使用vba选择“是”的记录，比如A

Selection.AutoFilter Field:=2, Criteria1:="yes"
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select

然后我将其复制粘贴到其他地方。例如：

Selection.Copy
Range("B12").Select
ActiveSheet.Paste

问题是，当没有记录为yes时，我得到错误1004.可能是因为没有要粘贴的内容。如何编写脚本，以便在没有要粘贴的内容时，它会退出子？

我尝试过像counta这样的东西，但没有成功。

非常感谢您的帮助！ ：）

Answer 1

我喜欢这样做，因为你不需要错误检查它。如果没有结果，则只需粘贴一个空白单元格：

Sub tgr()

    With Range("B2").CurrentRegion
        .AutoFilter 2, "yes"
        Intersect(.Offset(1), Columns("B")).Copy Range("B12")
        .AutoFilter
    End With

End Sub

或者，如果您只有一个条件，则可以在执行过滤器之前使用Countif来测试条件是否存在：

Sub tgr()

    Dim strCriteria As String

    strCriteria = "yes"

    With Range("B2").CurrentRegion
        If WorksheetFunction.CountIf(Intersect(.Cells, Columns("C")), strCriteria) > 0 Then
            .AutoFilter 2, strCriteria
            Intersect(.Offset(1), Columns("B")).Copy Range("B12")
            .AutoFilter
        Else
            MsgBox "No cells found to contain """ & strCriteria & """", , "No Matches"
        End If
    End With

End Sub

Answer 2

这将检查应用AutoFilter后的可见单元格数：

Selection.AutoFilter Field:=2, Criteria1:="yes"
If ActiveSheet.AutoFilter.Range.Rows.Offset(1, 0).SpecialCells(xlCellTypeVisible).Count - ActiveSheet.AutoFilter.Range.Columns.Count > 0 Then
    Range("B3").Select
    Range(Range("b3"), Range("b2").End(xlDown)).Select
    Selection.Copy
    Range("B12").Select
    ActiveSheet.Paste
End If

- ActiveSheet.AutoFilter.Range.Columns.Count部分是从计数中减去标题单元格。

FWIW，当我浏览原始代码时，我得到了1004，因为复制区域是从B7到工作表的底部（xlDown在空选中的效果）。

Answer 3

您可以使用SUBTOTAL工作表函数来计算可见行，只有在有可见行时才进行复制和粘贴。这是一个例子。

Sub CopyFiltered()

    Dim rToFilter As Range
    Dim rToCopy As Range
    Dim rToPaste As Range

    Set rToFilter = Selection
    Set rToPaste = rToFilter.Cells(1).Offset(10, 0) 'paste it 10 rows down

    rToFilter.AutoFilter 2, "yes"

    'Use subototal to count the visible rows in column 1
    If Application.WorksheetFunction.Subtotal(2, rToFilter.Columns(1)) > 0 Then
        'Copy excluding the header row
        Set rToCopy = rToFilter.Columns(1).Offset(1, 0).Resize(rToFilter.Rows.Count - 1)
        rToCopy.Copy Destination:=rToPaste
    End If

End Sub