只選擇過濾的單元

Question

我想過濾一個工作的列的顏色，然後我想讓Excel選擇所有被過濾的單元。不過，我不希望它選擇第一行。如果過濾爲空，我希望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 

任何建議？

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 here。

Answer 3

讓我想起了一些代碼，我寫了前一陣子。它不是專門針對您要求的內容（直接複製或採用顏色）而進行的，但對於處理濾鏡行間距的一般情況而言，這是一個非常方便的工具。

它做些什麼：如果該行是隱藏的，則在值爲0的工作表的第一個ListObject（表）中填充名爲「F」的字段，如果該行可見，則填充1。如果不存在列/字段「F」，則會創建並添加到表格的右端。然後，它清除所有圖紙過濾器，對F列進行排序，以便所有可見的行到達頂部，然後重新過濾。其結果是，您可以將所有過濾的值組合在一起，而不會出現間隙。其次，您可以通過重命名「F」列/字段來保存複雜的過濾器組合。

聲明：我前一段時間寫了這段代碼，我相信還有改進的空間。儘管這是我的目的，所以我只是沒有花時間。讓我知道你是否想出更好的東西。

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