只select过滤的单元格

我试图过滤一个工作的列上的颜色，然后我想要Excel来select所有被过滤的单元格。 不过，我不希望它select第一行。 如果过滤是空的，我希望Excel跳过复制，如果不是，那么继续。

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

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 

有什么build议么？

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 

关于这一点，请检查我的博客文章在这里 specialcells。

Answer 3

让我想起了前一段我写的一些代码。 它不是专门按照你要求的方式（直接复制或者按照颜色来操作），但是对于处理filter行距的一般情况来说，这是一个非常方便的工具。

它的作用是：在表单中的第一个ListObject（表）中填充名为“F”的字段，如果该行是隐藏的，则值为0;如果行是可见的，则填充1。 如果不存在列/字段“F”，则创build并添加在表的右端。 然后清除所有图纸filter，对列F进行sorting，使所有可见的行到达顶部，然后重新过滤。 结果就是你可以把所有你的过滤值合在一起，而且没有间隙。 其次，您可以通过重命名“F”列/字段来保存复杂的filter组合。

免责声明：我前一段时间写了这段代码，我相信还有改进的空间。 这是我的目的，所以我只是没有花时间。 让我知道如果你想出更好的东西。

 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