autofilter more than 2 with wildcard

[rfletcher35]

Hi,

I have tried to look to see if this has been solved but could not find so apologies if it is there.

This is the code I am using to filter on 2 criteria

'Filter for Diary / Calendar

    ActiveSheet.Range("$A$1:$G$90").AutoFilter Field:=3, Criteria1:="*Diary*", Operator:=xlOr, Criteria2:="*Calendar*"
   
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy

However I am repeating myself several time as I have to do this a number of times in my workbook looking for relevant criteria, I have tried the following if this makes sense.

ActiveSheet.Range("$A$1:$G$10000").AutoFilter Field:=3, _
                                 Criteria1:=Array("*Inbox*", "*Whitelist*", "*Diary*", "*Whitelist*", "*Inbox*"), _
                                 Operator:=xlFilterValues

The above only works with again 2 criteria but I need to have several in there so I can condense my code.

Can anyone please help with this.

Many Thanks

Fletch

 

[Peter_SSs]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

Criteria1:=Array("*Inbox*", "*Whitelist*", "*Diary*", "*Whitelist*", "*Inbox*")

Why are you repeating values in this list?

See if this does what you want. Test with a copy of your workbook.

Sub AF()
  Dim RX As Object, d As Object
  Dim a As Variant
  Dim i As Long
  
  Const myList As String = "Inbox|Whitelist|Diary" '<- Add more here if required
  
  Set d = CreateObject("Scripting.Dictionary")
  d.Comparemode = 1
  Set RX = CreateObject("VBScript.RegExp")
  RX.IgnoreCase = True
  RX.Pattern = myList
  a = Range("C2", Range("C" & Rows.Count).End(xlUp)).Value2
  For i = 1 To UBound(a)
    If RX.Test(a(i, 1)) Then d(a(i, 1)) = 1
  Next i
  Range("$A$1:$G$1").Resize(UBound(a)).AutoFilter Field:=3, Criteria1:=d.Keys, Operator:=xlFilterValues
End Sub

 

[vcoolio]

Hello Fletch,

It appears that you are attempting to filter on strings within a string using a wildcard as the key; e.g. "Bob lost his diary the other day".
As you're filtering on Column C, try something like this:-

Option Explicit
Sub Test()

    Dim ar As Variant, i As Integer
    Dim ws As Worksheet: Set ws = ActiveSheet  '---->The best option here is to use the sheet code.
    ar = Array("Inbox", "Whitelist", "Diary", "Whatever") '---->Add to the array as required.

Application.ScreenUpdating = False

 For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Somewhere").Range("A" & Rows.Count).End(3)(2)
        End With
 Next i
    
Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

 

[vcoolio]

.................or just use Peter's code!

 

[rfletcher35]

I will try it now thanks, will this negate the requirement for Wildcards as these are keywords within sentences?

 

[Peter_SSs]

.. will this negate the requirement for Wildcards ..

It will. As you have found, there is a limit of only two values that you can use with wildcards like you were attempting.

.. but do note that if "apple" is a keyword "pineapple" would be included in the filter, just as it would have been with your wildcard code.

 

[rfletcher35]

Hello Fletch,

It appears that you are attempting to filter on strings within a string using a wildcard as the key; e.g. "Bob lost his diary the other day".
As you're filtering on Column C, try something like this:-

Option Explicit
Sub Test()

    Dim ar As Variant, i As Integer
    Dim ws As Worksheet: Set ws = ActiveSheet  '---->The best option here is to use the sheet code.
    ar = Array("Inbox", "Whitelist", "Diary", "Whatever") '---->Add to the array as required.

Application.ScreenUpdating = False

 For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Somewhere").Range("A" & Rows.Count).End(3)(2)
        End With
 Next i
   
Application.ScreenUpdating = True

End Sub

I hope that this helps.

Cheerio,
vcoolio.

Hi, Tried this code and it works brilliantly, until I got to one with about 22, is there a limit on how many you can have in this one?

 

[rfletcher35]

Hi, Tried this code and it works brilliantly, until I got to one with about 22, is there a limit on how many you can have in this one?

Ignore last comment was making a mistake, however hopefully one last thing, after choosing and copying into another sheet I had it deleting the selected cells following the copy, any idea how I can fit this in please?
My code looks like this so far, as you can see different Criteria will paste into different sheets, after completing all selections it then copies the remainder into another sheet.

'Filter for Outlook / Email /Diary / Whitelist / Spam / Mailbox / Inbox / Calendar / Diaries
   
    Dim ar As Variant, i As Integer
    Dim ws As Worksheet: Set ws = ActiveSheet  '---->The best option here is to use the sheet code.
    ar = Array("Inbox", "Whitelist", "Diary", "Email", "Outlook", "Spam", "Mailbox", "inbox", "Calendar", "Diaries") '---->Add to the array as required.


 For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Emails").Range("A" & Rows.Count).End(3)(2)
                    '.Range("A1:G100000").Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
 Next i
 
    ar = Array("Starter", "Login", "Offb", "Leav", "User", "New Joiner", "Set Up", "Licen") '---->Add to the array as required.
    For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Users").Range("A" & Rows.Count).End(3)(2)
                   
        End With
 Next i
 
 ar = Array("Inbox", "Internet", "Wifi", "Website") '---->Add to the array as required.
    For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Internet").Range("A" & Rows.Count).End(3)(2)
                   
        End With
 Next i
 
 ar = Array("PDF", "Pay", "Install", "Software", "Invenias", "Invenius", "Sharepoint", "efore", "Iscala", "Power B", "Dymo", "Teams", "Documents", "OneDrive", "One Drive", "Zero", "Expensify", "Keevio", "Sage", "Adobe", "Nitro", "Antivirus", "Excel") '---->Add to the array as required.
    For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Applications").Range("A" & Rows.Count).End(3)(2)
                   
        End With
 Next i
 
 ar = Array("Daily Status Report", "Backup", "3CX Phone System", "Subscription Renewal", "Webinar", "Trunk", "Webinar", "PBX", "Weekly Restart", "WatchGuard", "Planned", "Successfully Renewed", "Device", "Datsons", "Device", "Acronis Cyber", "Service Update", "Upgrade Your", "Critical Security", "Security Threat", "Roundworks", "Subscription", "Renew Your", "Avalon IT", "Maintenence", "Now Available", "synchronization", "Services Notification", "Healing", "Alert", "Verification", "Microsoft 365", "Invoice", "CSP", "Invoice", "Invoice") '---->Add to the array as required.
    For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Notifications").Range("A" & Rows.Count).End(3)(2)
                   
        End With
 Next i

 

[rfletcher35]

Ignore last comment was making a mistake, however hopefully one last thing, after choosing and copying into another sheet I had it deleting the selected cells following the copy, any idea how I can fit this in please?
My code looks like this so far, as you can see different Criteria will paste into different sheets, after completing all selections it then copies the remainder into another sheet.

'Filter for Outlook / Email /Diary / Whitelist / Spam / Mailbox / Inbox / Calendar / Diaries
  
    Dim ar As Variant, i As Integer
    Dim ws As Worksheet: Set ws = ActiveSheet  '---->The best option here is to use the sheet code.
    ar = Array("Inbox", "Whitelist", "Diary", "Email", "Outlook", "Spam", "Mailbox", "inbox", "Calendar", "Diaries") '---->Add to the array as required.


 For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Emails").Range("A" & Rows.Count).End(3)(2)
                    '.Range("A1:G100000").Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
 Next i
 
    ar = Array("Starter", "Login", "Offb", "Leav", "User", "New Joiner", "Set Up", "Licen") '---->Add to the array as required.
    For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Users").Range("A" & Rows.Count).End(3)(2)
                  
        End With
 Next i
 
 ar = Array("Inbox", "Internet", "Wifi", "Website") '---->Add to the array as required.
    For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Internet").Range("A" & Rows.Count).End(3)(2)
                  
        End With
 Next i
 
 ar = Array("PDF", "Pay", "Install", "Software", "Invenias", "Invenius", "Sharepoint", "efore", "Iscala", "Power B", "Dymo", "Teams", "Documents", "OneDrive", "One Drive", "Zero", "Expensify", "Keevio", "Sage", "Adobe", "Nitro", "Antivirus", "Excel") '---->Add to the array as required.
    For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Applications").Range("A" & Rows.Count).End(3)(2)
                  
        End With
 Next i
 
 ar = Array("Daily Status Report", "Backup", "3CX Phone System", "Subscription Renewal", "Webinar", "Trunk", "Webinar", "PBX", "Weekly Restart", "WatchGuard", "Planned", "Successfully Renewed", "Device", "Datsons", "Device", "Acronis Cyber", "Service Update", "Upgrade Your", "Critical Security", "Security Threat", "Roundworks", "Subscription", "Renew Your", "Avalon IT", "Maintenence", "Now Available", "synchronization", "Services Notification", "Healing", "Alert", "Verification", "Microsoft 365", "Invoice", "CSP", "Invoice", "Invoice") '---->Add to the array as required.
    For i = 0 To UBound(ar)
        With ws.Range("C1", Range("C" & Rows.Count).End(xlUp))
                    .AutoFilter 1, "*" & ar(i) & "*"
                    .Offset(1).EntireRow.Copy Sheets("Notifications").Range("A" & Rows.Count).End(3)(2)
                  
        End With
 Next i

I used, Range("A1:G100000").Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete to delete the rows before

 

[Peter_SSs]

My code looks like this so far

Are you sure that is even close to what you are wanting? For me, it is resulting in what I would have thought are strange results on some of the destination sheets, including hidden rows.

BTW, about how many rows in the original sheet? Is it anything like the 100,000 rows suggested by

I used, Range("A1:G100000").