Excel vba только отфильтрованные строки

The SpecialCells Does not actually work as it needs to be continuous. I have solved this by adding a sort funtion in order to sort the data based on the coloumns i need.

Sorry for no comments on the code as i was not planning to share it:

Sub testtt()
    arr = FilterAndGetData(Worksheets("Data").range("A:K"), Array(1, 9), Array("george", "WeeklyCash"), Array(1, 2, 3, 10, 11), 1)
    Debug.Print sms(arr)
End Sub
Function FilterAndGetData(ByVal rng As Variant, ByVal fields As Variant, ByVal criterias As Variant, ByVal colstoreturn As Variant, ByVal headers As Boolean) As Variant
Dim SUset, EAset, CMset
If Application.ScreenUpdating Then Application.ScreenUpdating = False: SUset = False Else SUset = True
If Application.EnableEvents Then Application.EnableEvents = False: EAset = False Else EAset = True
If Application.Calculation = xlCalculationAutomatic Then Application.Calculation = xlCalculationManual: CMset = False Else CMset = True
For Each col In rng.Columns: col.Hidden = False: Next col

Dim oldsheet, scol, ecol, srow, hyesno As String
Dim i, counter As Integer

oldsheet = ActiveSheet.Name


Worksheets(rng.Worksheet.Name).Activate

Worksheets(rng.Worksheet.Name).AutoFilterMode = False

scol = Chr(rng.Column + 64)
ecol = Chr(rng.Columns.Count + rng.Column + 64 - 1)
srow = rng.row

If UBound(fields) - LBound(fields) <> UBound(criterias) - LBound(criterias) Then FilterAndGetData = "Fields&Crit. counts dont match": GoTo done

dd = sortrange(rng, colstoreturn, headers)

For i = LBound(fields) To UBound(fields)
    rng.AutoFilter Field:=CStr(fields(i)), Criteria1:=CStr(criterias(i))
Next i

Dim rngg As Variant

rngg = rng.SpecialCells(xlCellTypeVisible)
Debug.Print ActiveSheet.AutoFilter.range.address
FilterAndGetData = ActiveSheet.AutoFilter.range.SpecialCells(xlCellTypeVisible).Value

For Each row In rng.Rows
    If row.EntireRow.Hidden Then Debug.Print yes
Next row


done:
    'Worksheets("Data").AutoFilterMode = False
    Worksheets(oldsheet).Activate
    If SUset Then Application.ScreenUpdating = True
    If EAset Then Application.EnableEvents = True
    If CMset Then Application.Calculation = xlCalculationAutomatic
End Function
Function sortrange(ByVal rng As Variant, ByVal colnumbers As Variant, ByVal headers As Boolean)

    Dim SUset, EAset, CMset
    If Application.ScreenUpdating Then Application.ScreenUpdating = False: SUset = False Else SUset = True
    If Application.EnableEvents Then Application.EnableEvents = False: EAset = False Else EAset = True
    If Application.Calculation = xlCalculationAutomatic Then Application.Calculation = xlCalculationManual: CMset = False Else CMset = True
    For Each col In rng.Columns: col.Hidden = False: Next col

    Dim oldsheet, scol, srow, sortcol, hyesno As String
    Dim i, counter As Integer
    oldsheet = ActiveSheet.Name
    Worksheets(rng.Worksheet.Name).Activate
    Worksheets(rng.Worksheet.Name).AutoFilterMode = False
    scol = rng.Column
    srow = rng.row

    If headers Then hyesno = xlYes Else hyesno = xlNo

    For i = LBound(colnumbers) To UBound(colnumbers)
        rng.Sort key1:=range(Chr(scol + colnumbers(i) + 63) + CStr(srow)), order1:=xlAscending, Header:=hyesno
    Next i
    sortrange = "123"
done:
    Worksheets(oldsheet).Activate
    If SUset Then Application.ScreenUpdating = True
    If EAset Then Application.EnableEvents = True
    If CMset Then Application.Calculation = xlCalculationAutomatic
End Function

Я не знаю, какой именно код с сайта Pashulka Вы используте. Но если речь идет именно об Автофильтре, то в коде должна быть инструкция, похожая на это:

    Workbooks(i).Worksheets(k).AutoFilter Field:=1, Criteria1:="4"

— где вместо Workbooks(i).Worksheets(k) может быть любая конструкция, возвращающая объект листа с автофильтром, а значения параметров Field и Criteria различны.

Видимо после этой инструкции должна быть часть кода, которая считает количество строк, отфильтрованных автофильтром. Так?

Если после подсчета количества строк нужно выделить все видимые строки (после фильтрации) и удалить их, то я бы сделал это так:

Допустим ws — это объектная переменная, возвращающая лист с нашим автофильтром, (например, Set ws = ActiveSheet)

    Set mr = ws.AutoFilter.Range.Offset(1, 0). _
        Resize(ws.AutoFilter.Range.Rows.Count - 1, ws.AutoFilter.Range.Columns.Count)
    mr.SpecialCells(xlCellTypeVisible).EntireRow.Delete

Здесь mr — будет областью Range Автофильтра на листе ws без строки заголовков.
А вторая инструкция удалит все строки выбранные автофильтром (т.е. видимые после выборки автофильтра). Если вместо слова Delete написать Select, то вместо удаления будет происходить выделение строк.

Reminds me of some code I wrote a while ago. It’s not tailored to do exactly what you’re asking (directly copying or acting on colors), but it’s a very handy tool for the general case of handling filter row gaps.

What it does: Populates a field named «F» in the first ListObject (Table) in a sheet with a value 0 if the row is hidden, or 1 if the row is visible. If no column/field «F» exists, one gets created and added at the right end of the table. Then It clears all sheet filters, sorts column F so all visible rows come to the top, then re-filters. The result is that you get all your filtered values together without gaps in between. A secondary effect is that you can save a complex combination of filters by renaming the «F» column/field.

Disclaimer: I wrote this code a while ago and I’m sure there’s room for improvement. It’s served my purpose though, so I just haven’t taken the time. let me know if you come up with anything better.

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