Только отфильтрованные ячейки

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

Напоминает какой-то код, который я написал некоторое время назад. Он не предназначен для того, чтобы делать именно то, что вы просите (прямое копирование или действие по цветам), но это очень удобный инструмент для общего случая обработки пробелов в фильтрах.

Что он делает: заполняет поле с именем «F» в первом элементе ListObject (Table) на листе со значением 0, если строка скрыта, или 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