Question

我正在尝试过滤有效的列上的颜色，然后我希望Excel选择所有已过滤的单元格。但是我不想让它选择第一行。如果过滤后为空，我希望Excel跳过复制，如果没有则继续。

到目前为止，我有以下内容（不同的R，G，B代码用于颜色过滤，Color是我可以输入的工作表的名称）：

    Sub ColourWork(Colour As String, RCode As String, GCode As String, BCode As String)

        Dim rCopy As Range

        'Q1======

        Sheets("Combine").Select
        ActiveSheet.Range("$A:$AJ").AutoFilter

        ActiveSheet.Range("$A$1:$AJ$493").AutoFilter Field:=8, Criteria1:=RGB(RCode, GCode, BCode), Operator:=xlFilterCellColor

        'here is the issue! Because it cannot copy/select nothing! 

        On Error GoTo Error1
        Set rCopy = ActiveSheet.AutoFilter.Range.Offset(1, 0).Copy

        Sheets(Colour).Select

        If IsEmpty(Range("A1").Value) = True Then

            Range("$A$2").Select
            ActiveSheet.Paste

        Else

            Range("$A$2").Select
            Range(Selection, Selection.End(xlDown)).Select
            ActiveSheet.Paste

        End If

Point1:

Error1:

GoTo Point1

End Sub

有什么建议吗？

Answer 1

你走了：

Sub ColourWork(Colour As String, RCode As String, GCode As String, BCode As String)
    Dim rCopy As Range
    Sheets("Combine").Select
    With [a:aj].AutoFilter(8, RGB(RCode, GCode, BCode), xlFilterCellColor)
        Set rCopy = .Range.Offset(1).SpecialCells(xlCellTypeVisible).Copy
        Sheets(Colour).Select
        [index(a:a,1+max(iferror(match({"*";9E+99},a:a,{-1;1}),1)))].Paste
    End With
End Sub

Answer 2

使用Specialcells(xlcelltypevisible)，例如

    Set rCopy = ActiveSheet.AutoFilter.Range.Offset(1, 0).Specialcells(xlcelltypevisible).Copy

如需了解更多信息，请查看我在特殊主题here上的博文。

Answer 3

让我想起我刚才写的一些代码。它并不是专门为你所要求的（直接复制或作用于颜色）而量身定做的，但它对于处理滤镜行间隙的一般情况来说是一个非常方便的工具。

它的作用：填充名为＆＃34; F＆＃34;的字段。在工作表的第一个ListObject（表）中，如果隐藏行，则值为0;如果该行可见，则为1。如果没有列/字段＆＃34; F＆＃34;存在，一个被创建并添加在表的右端。然后它清除所有工作表过滤器，对列F进行排序，使所有可见行都到达顶部，然后重新过滤。结果是您将所有过滤后的值合在一起，两者之间没有间隙。第二个影响是，您可以通过重命名＆＃34; F＆＃34;来保存复杂的过滤器组合。列/场。

免责声明：我刚才写了这段代码，我确信还有改进的余地。虽然它符合我的目的，所以我还没有花时间。如果你想出更好的东西，请告诉我。

Sub Filter_By_Sorting()
Application.ScreenUpdating = False
Dim r As Double
Dim C As Double
Dim A As Worksheet
Set A = ActiveSheet
r = A.ListObjects(1).ListRows(1).Range.Row
On Error Resume Next
C = A.Range(ActiveSheet.ListObjects(1).Name & "[F]").Column
    If Err <> 0 Then
         C = A.ListObjects(1).ListColumns(A.ListObjects(1).ListColumns.Count).Range.Column + 1
         Columns(C).Select
         Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
         Cells(A.ListObjects(1).ListRows(1).Range.Row - 1, C) = "F"
    End If
On Error GoTo 0
Dim end_r As Double
end_r = A.ListObjects(1).ListRows.Count + A.ListObjects(1).ListRows(1).Range.Row - 1
Dim e() As Double
ReDim e(r To end_r, 0)
    Do Until r > end_r
        If A.Rows(r).EntireRow.Hidden = False Then
            e(r, 0) = 1
        Else
            e(r, 0) = 0
        End If
        r = r + 1
    Loop
    A.Cells(A.ListObjects(1).ListRows(1).Range.Row, _
    A.ListObjects(1).ListColumns(1).Range.Column).Select
    'Application.ScreenUpdating = True
    On Error Resume Next
    ActiveSheet.ShowAllData
        If Err <> 0 Then
            MsgBox "No Filter Detected, Macro Aborted"
            Exit Sub
        End If
    On Error GoTo 0
    'Application.ScreenUpdating = False
    Range(Cells(A.ListObjects(1).ListRows(1).Range.Row, C), Cells(end_r, C)) = e
    A.ListObjects.Item(1).Sort.SortFields.Clear
    A.ListObjects.Item(1).Sort.SortFields. _
        Add Key:=Range(A.ListObjects.Item(1).Name & "[F]"), SortOn:=xlSortOnValues, Order:=xlDescending _
        , DataOption:=xlSortNormal
    With A.ListObjects.Item(1).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   'A.Range(ActiveSheet.ListObjects(1).Name & "[F]").AutoFilter Criteria1:="1"
   A.ListObjects(1).Range.AutoFilter Field:=C, Criteria1:="1"
End Sub

仅选择过滤的单元格

3 个答案: