VBA: Autofilter

[Xlacs]

Hi Everyone,

Good Day to you all.

I'm in need of assistance regarding a particular problem of autofiltering..
The below code, filters a specific column and extract the data..

However, the file that I'm extracting is protected and already filtered and there's no way to obtain the password.
My question is it is possible to just extract the information and tell my codes that file is already filtered? I mean, how to modify my codes base on my scenario?

Thanks in Advance guys.

I'm getting an error of this line

.Range("B8").CurrentRegion.AutoFilter _
                 Field:=1, Criteria1:=">=" & CLng(startDate), _
                 Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)

Set colFiles = GetMatches(START_FOLDER, "*.xlsx*") '<< ###fixed
    For Each f In colFiles
        Set fromWorkbook = Workbooks.Open(f, ReadOnly:=True)
        With fromWorkbook.Worksheets(1)
            .Range("B8").CurrentRegion.AutoFilter _
                 Field:=1, Criteria1:=">=" & CLng(startDate), _
                 Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
                
            .Range("B8").CurrentRegion.Offset(IIf(destCell.Row = 1, 0, 1)).Copy destCell
        End With
        fromWorkbook.Close False
      
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
    Next f
   
    MsgBox "Finished"
End Sub

 

[Domenic]

Try replacing...

        With fromWorkbook.Worksheets(1)
            .Range("B8").CurrentRegion.AutoFilter _
                 Field:=1, Criteria1:=">=" & CLng(startDate), _
                 Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
                
            .Range("B8").CurrentRegion.Offset(IIf(destCell.Row = 1, 0, 1)).Copy destCell
        End With

with

       With fromWorkbook.Worksheets(1).AutoFilter.Range
            .Offset(IIf(destCell.Row = 1, 0, 1)).Copy destCell
       End With

Hope this helps!

 

[Xlacs]

Thank you, Im getting closer.. However, "object variable or with block variable not set.."

This Line

 With fromWorkbook.Worksheets(1).AutoFilter.Range

Below is my code

Public Sub Copy_AutoFiltered_Rows_From_Workbooks()
   
    Const START_FOLDER As String = "C:\Users\xxx\Desktop\Extract\"
   
    Dim destCell As Range, fromWorkbook As Workbook
    Dim startDate As Date, endDate As Date, colFiles As Collection, f
   
    With ThisWorkbook.ActiveSheet
        If Not IsDate(.Range("A1").Value) Or IsEmpty(.Range("A1").Value) Or _
           Not IsDate(.Range("A2").Value) Or IsEmpty(.Range("A2").Value) Then
            MsgBox "Cells A1 and A2 must contain a date"
            Exit Sub
        End If
        startDate = .Range("A1").Value
        endDate = .Range("A2").Value
        If startDate > endDate Then
            MsgBox "Start date in A1 must be earlier than end date in A2"
            Exit Sub
        End If
        Set destCell = .Cells(.Rows.Count, "B").End(xlUp)
    End With
    Application.ScreenUpdating = False
   
    Set colFiles = GetMatches(START_FOLDER, "*.xlsx*") '<< ###fixed
    For Each f In colFiles
        Set fromWorkbook = Workbooks.Open(f, ReadOnly:=True)
        With fromWorkbook.Worksheets(1).AutoFilter.Range
            .Offset(IIf(destCell.Row = 1, 0, 1)).Copy destCell
       End With
       
    Next f
   
    MsgBox "Finished"
End Sub

'Return a collection of file paths given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr, fpath
    Dim colFiles As New Collection
    Dim colSub As New Collection
   
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
   
    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
       
        fpath = fldr.Path
        If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
        f = Dir(fpath & filePattern) 'Dir is faster...
        Do While Len(f) > 0
            colFiles.Add fpath & f
            f = Dir()
        Loop
    Loop
    Set GetMatches = colFiles
End Function

 

[Domenic]

If the filter for fromWorkbook.Worksheets(1) is not turned on, you'll get that error. Is it in fact turned on?

 

[Xlacs]

If the filter for fromWorkbook.Worksheets(1) is not turned on, you'll get that error. Is it in fact turned on?

Yes it is.. It's already filtered

 

[ajm]

try testing for the filter first and then using .showalldata. sort of like "with your sheet in your file, if sheetname.autofilter = true, then .ShowAllData"

then reapply the filter. trying to find the right syntax in my folder of snippets so may have the wrong everything.....

 

[Alex Blakenburg]

Your original code worked for me on my test data but I am assuming the issue was that it didn't remove the previous filter(s) which is inline with @ajm's comment.

I would normally at the filter mode test with a show all, in the position in your code as shown below.
I would like to know more about your protection comment since with the worksheet protection enabled, I can't get any of the VBA filter functions to work even with Autofilter ticked when I apply the protection to the sheet.

        With fromWorkbook.Worksheets(1)
            If .FilterMode Then .ShowAllData    ' Remove existing filters
            .Range("B8").CurrentRegion.AutoFilter _
                 Field:=1, Criteria1:=">=" & CLng(StartDate), _
                 Operator:=xlAnd, Criteria2:="<=" & CLng(EndDate)

 

[Domenic]

Actually, since the data is already filtered, and since only visible cells are copied when filtered data is copied and pasted, I think you can simply remove the part of your code that filters the data. So you would replace...

        With fromWorkbook.Worksheets(1)
            .Range("B8").CurrentRegion.AutoFilter _
                 Field:=1, Criteria1:=">=" & CLng(startDate), _
                 Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
               
            .Range("B8").CurrentRegion.Offset(IIf(destCell.Row = 1, 0, 1)).Copy destCell
        End With

with

 fromWorkbook.Worksheets(1).Range("B8").CurrentRegion.Offset(IIf(destCell.Row = 1, 0, 1)).Copy destCell