[VBA] Multiple criterias in filter

[Eawyne]

Hi all,

okay, this is driving me nuts. I'm trying to apply a filter on a generated table via VBA, and I want several criterias to be used. I've come up with various methods, notably using this link https://docs.microsoft.com/fr-fr/office/vba/api/excel.range.autofilter

The one more approriate for my purpose seems to be the one using the Array variable.

The problem is that despite all indications of the contrary, the execution on my code stops at two criterias. I've found several instances of codes having four, five criterias, and people say it works, but I can only have two !

'Filtre les résultats /!\ Test
ActiveSheet.Range("A1:F200").AutoFilter _
Field:=4, _
Criteria1:=Array("*.pdf", "*.pptx", "*.xlsx"), _
Operator:=xlFilterValues

Could someone help me figure this out ? What am I missing here ? There's the XOR variable too, but this seems to have a limit as well - at least, adding Criteria3 doesn't yield any result.
(And I really hope it's not just me being a dumbass here...)

 

[Fluff]

You can only use more than 2 criteria when doing an exact match. Three alternatives would be
1) Have a look at using an advanced filter instead.
2) Put a formula to the side of the data that shows which rows should be visible & filter on that
3) Loop through your data getting the exact values to filter on & use that as an array.

 

[kevin9999]

@Fluff is spot on in their advice. If you went for Fluff's option #3, the code could look like this:

Option Explicit
Sub WildCardFilter()
    Dim i As Long, ws As Worksheet, lr As Long, c As Range, arr() As Variant
    Set ws = ActiveSheet
    lr = ws.Cells(Rows.Count, 4).End(xlUp).Row
    
    For Each c In ws.Range("D2:D" & lr)
        If c.Value Like "*.pdf" Or _
            c.Value Like "*.xlxs" Or _
            c.Value Like "*.pptx" Then
                ReDim Preserve arr(i)
                arr(i) = c.Value
                i = i + 1
        End If
    Next c
    
    With ws.Range("A1").CurrentRegion
        .AutoFilter 4, Array(arr), 7
    End With
End Sub

 

[Eawyne]

Hey,

so I've tried splicing your code into mine, but I get an error : Run-time error '5' : Invalid procedure call or argument - on the following line at the end of your code :

.AutoFilter 4, Array(arr), 7

Here's the code I'm trying to update (your part is at the end) :

Public Sub CollectHyperlinks()
    
    'Option Explicit
    
    Dim Sht         As Worksheet, Hl As Hyperlink, FSO As Object
    Dim arr22()     As Variant, i As Long, Anchor As Object
    Dim FileMsg     As String, AnchorMsg As String
    Dim p           As Long, ws As Worksheet, lr As Long, c As Range, arr() As Variant
    Set ws = ActiveSheet
    lr = ws.Cells(Rows.Count, 4).End(xlUp).Row
    
    ReDim arr2(1 To 1000, 1 To 9)
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    i = 1
    arr2(i, 1) = "Worksheet"
    arr2(i, 2) = "Hyperlink Anchor"
    arr2(i, 3) = "File"
    arr2(i, 4) = "Hyperlink Name"
    arr2(i, 5) = "Hyperlink Address"
    arr2(i, 6) = "SubAddress"
    arr2(i, 7) = "ScreenTip"
    arr2(i, 8) = "TextToDisplay"
    arr2(i, 9) = "EmailSubject"
    
    For Each Sht In ThisWorkbook.Worksheets
        For Each Hl In Sht.Hyperlinks
            Set Anchor = Nothing
            AnchorMsg = ""
            FileMsg = ""
            With Hl
                If FSO.FileExists(.address) Then FileMsg = "Exists"
                On Error Resume Next
                Set Anchor = .Range
                If Not Anchor Is Nothing Then
                    AnchorMsg = Anchor.address
                Else
                    Set Anchor = .Shape
                    If Not Anchor Is Nothing Then
                        AnchorMsg = Anchor.Name
                    End If
                End If
                i = i + 1
                arr2(i, 1) = Sht.Name
                arr2(i, 2) = AnchorMsg
                arr2(i, 3) = FileMsg
                arr2(i, 4) = .Name
                arr2(i, 5) = .address
                arr2(i, 6) = .SubAddress
                arr2(i, 7) = .ScreenTip
                arr2(i, 8) = .TextToDisplay
                arr2(i, 9) = .EmailSubject
                On Error GoTo 0
            End With
        Next Hl
    Next Sht
    Application.ScreenUpdating = FALSE
    With Application.Workbooks.Add.Sheets(1)
        .Range("A2").Select
        ActiveWindow.FreezePanes = TRUE
        With .Rows("1:1")
            .Interior.color = 10837023
            .Font.color = RGB(255, 255, 255)
            .Font.Bold = TRUE
        End With
        .Range("A1").Resize(UBound(arr2, 1), UBound(arr2, 2)).Value = arr2
        .Columns("A:I").Columns.AutoFit
        
        'Trie les valeurs dans l'ordre alphabétique dans une colonne choisie - ici, D
        Range("C1") = "Index"
        Columns("A:C").Sort key1:=Range("C2"), order1:=xlAscending, Header:=xlYes
        
        For Each c In ws.Range("D2:D" & lr)
            If c.Value Like "*.pdf" Or _
               c.Value Like "*.xlxs" Or _
               c.Value Like "*.pptx" Then
            ReDim Preserve arr(p)
            arr(p) = c.Value
            p = p + 1
        End If
    Next c
    
    With ws.Range("A1").CurrentRegion
        .AutoFilter 4, Array(arr), 7
    End With
    
End With
Application.ScreenUpdating = TRUE
End Sub

As there were some conflicts with variable names, I tried to change them accordingly to avoid any error, but even like that, it doesn't work. I tried the code you provided on a simple page wihout anything else, and it works fine. I also tried the code on the newly generated workbook, and it also works fine on its own.

 

[kevin9999]

@Eawyne - I usually prefer not to set Worksheet variables to the ActiveSheet - so let's start by being more explicit with the Set ws line:

Change

Set ws = ActiveSheet

to

Set ws = ThisWorkook.Sheets("ActualSheetName")

where ActualSheetName is the name of the sheet containing the data you wish to filter.

Hopefully it's a simple fix like that - which it should be given that the stand alone code works correctly in isolation. Also, not that it might matter too much, I note that you declare

Arr22

as Variant, but refer to

Arr2

in other places in your code?

Cheers

 

[Eawyne]

It doesn't seem to please the VBA gods, I get this error on the corrected Set ws : Run-time error '9' : Subscript out of range

I've tried several other variants of the Workbook variable, without much change.

Also, about the Arr2, pay no heed, it was simply me trying out stuff, and I didn't provide the cleaner version of the code! It shouldn't have an impact anyway, as you say

 

[kevin9999]

I've noticed a typo in the code I gave you last time (doh!). Should have read:

Set ws = ThisWorkbook.Sheets("ActualSheetName")

Subscript out of range means it cannot find the sheet you're referring to in your code. This means that either there's a problem with the spelling of the sheet name, or that the sheet is not part of the workbook that contains the code you are running. If the latter is true, then you need to refer to it differently, such as:

Set ws = WorkBook("Workbook_Name").Sheets("Sheet_Name")

If none of these things fix the problem, then you'll need to upload the file before I can help any further.
Good Luck

 

[Eawyne]

Due to work restrictions, I can't really send you the file as is - or at all, for that matter. So here's the code itself, without yours, untouched and working. You'd have to add a few phony links on Sheet1. Sorry to ask so much of you =/

       Public Sub CollectHyperlinks()
Dim Sht         As Worksheet, Hl As Hyperlink, FSO As Object
Dim arr()       As Variant, i As Long, Anchor As Object
Dim FileMsg     As String, AnchorMsg As String
   
ReDim arr(1 To 1000, 1 To 9)
Set FSO = CreateObject("Scripting.FileSystemObject")
   
i = 1
arr(i, 1) = "Worksheet"
arr(i, 2) = "Hyperlink Anchor"
arr(i, 3) = "File"
arr(i, 4) = "Hyperlink Name"
arr(i, 5) = "Hyperlink Address"
arr(i, 6) = "SubAddress"
arr(i, 7) = "ScreenTip"
arr(i, 8) = "TextToDisplay"
arr(i, 9) = "EmailSubject"
   
For Each Sht In ThisWorkbook.Worksheets
For Each Hl In Sht.Hyperlinks
Set Anchor = Nothing
AnchorMsg = ""
FileMsg = ""
With Hl
If FSO.FileExists(.Address) Then FileMsg = "Exists"
On Error Resume Next
Set Anchor = .Range
If Not Anchor Is Nothing Then
AnchorMsg = Anchor.Address
Else
Set Anchor = .Shape
If Not Anchor Is Nothing Then
AnchorMsg = Anchor.Name
End If
End If
i = i + 1
arr(i, 1) = Sht.Name
arr(i, 2) = AnchorMsg
arr(i, 3) = FileMsg
arr(i, 4) = .Name
arr(i, 5) = .Address
arr(i, 6) = .SubAddress
arr(i, 7) = .ScreenTip
arr(i, 8) = .TextToDisplay
arr(i, 9) = .EmailSubject
On Error GoTo 0
End With
Next Hl
Next Sht
Application.ScreenUpdating = FALSE
With Application.Workbooks.Add.Sheets(1)
.Range("A2").Select
ActiveWindow.FreezePanes = TRUE
With .Rows("1:1")
.Interior.Color = 10837023
.Font.Color = RGB(255, 255, 255)
.Font.Bold = TRUE
End With
.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
.Columns("A:I").Columns.AutoFit
       
'Trie les valeurs dans l'ordre alphabétique dans une colonne choisie - ici, D
Range("C1") = "Index"
Columns("A:C").Sort key1:=Range("C2"), order1:=xlAscending, Header:=xlYes
       
End With
Application.ScreenUpdating = TRUE
End Sub

 

[GWteB]

Your post #8 code looks familiar

Would recommend to adjust @kevin9999 's code to a method in such a way it accepts a worksheet object as an argument.
That way the code stays easier to read and to maintain.

It would look like:

Sub WildCardFilter(ByVal argSht As Worksheet)
    Dim i As Long, lr As Long, c As Range, arr() As Variant
    With argSht
        lr = .Cells(.Rows.Count, 4).End(xlUp).Row
        For Each c In .Range("D2:D" & lr)
            If c.Value Like "*.pdf" Or _
               c.Value Like "*.xlxs" Or _
               c.Value Like "*.pptx" Then
                ReDim Preserve arr(i)
                arr(i) = c.Value
                i = i + 1
            End If
        Next c
        With .Range("A1").CurrentRegion
            .AutoFilter 4, Array(arr), 7
        End With
    End With
End Sub

Your post #8 code would need a small modification:

Public Sub CollectHyperlinks()
    Dim Sht         As Worksheet, Hl As Hyperlink, FSO As Object
    Dim arr()       As Variant, i As Long, Anchor As Object
    Dim FileMsg     As String, AnchorMsg As String
   
    ReDim arr(1 To 1000, 1 To 9)
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    i = 1
    arr(i, 1) = "Worksheet"
    arr(i, 2) = "Hyperlink Anchor"
    arr(i, 3) = "File"
    arr(i, 4) = "Hyperlink Name"
    arr(i, 5) = "Hyperlink Address"
    arr(i, 6) = "SubAddress"
    arr(i, 7) = "ScreenTip"
    arr(i, 8) = "TextToDisplay"
    arr(i, 9) = "EmailSubject"
   
    For Each Sht In ThisWorkbook.Worksheets
        For Each Hl In Sht.Hyperlinks
            Set Anchor = Nothing
            AnchorMsg = ""
            FileMsg = ""
            With Hl
                If FSO.FileExists(.Address) Then FileMsg = "Exists"
                On Error Resume Next
                Set Anchor = .Range
                If Not Anchor Is Nothing Then
                    AnchorMsg = Anchor.Address
                Else
                    Set Anchor = .Shape
                    If Not Anchor Is Nothing Then
                        AnchorMsg = Anchor.Name
                    End If
                End If
                i = i + 1
                arr(i, 1) = Sht.Name
                arr(i, 2) = AnchorMsg
                arr(i, 3) = FileMsg
                arr(i, 4) = .Name
                arr(i, 5) = .Address
                arr(i, 6) = .SubAddress
                arr(i, 7) = .ScreenTip
                arr(i, 8) = .TextToDisplay
                arr(i, 9) = .EmailSubject
                On Error GoTo 0
            End With
        Next Hl
    Next Sht
    Application.ScreenUpdating = False

    Set Sht = Application.Workbooks.Add.Sheets(1)
    With Sht
        .Range("A2").Select
        ActiveWindow.FreezePanes = True
        With .Rows("1:1")
            .Interior.Color = 10837023
            .Font.Color = RGB(255, 255, 255)
            .Font.Bold = True
        End With
        .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
        .Columns("A:I").Columns.AutoFit
       
        'Trie les valeurs dans l'ordre alphabétique dans une colonne choisie - ici, D
        Range("C1") = "Index"
        Columns("A:C").Sort key1:=Range("C2"), order1:=xlAscending, Header:=xlYes
       
        WildCardFilter Sht
    
    End With
    Application.ScreenUpdating = True
End Sub