Unable to autofilter for 'Begins With' and 'Does Not Contain' in same VBA array

[honkin]

I have a worksheet which collects data for football matches and I want to filter for 2 text strings, but eliminate 2 others.

I had previously just used autofilter with 2 criteria to produce anything beginning with LTD or MARIA1, but it just gives too many results which also end with CSP or BTD, so I wanted to try and exclude them, so opted for trying a VBA array

The array I wrote was the following arr = Array("LTD*", "MARIA1*", "<>CSP", "<>BTD") but this falls over giving an RTE 1004 Method 'AutoFilter' of object 'Range' failed

Here is the entire code

Sub LAY_THE_DRAW_DAILY()
   
   Dim arr, ws As Worksheet, lc As Long, lr As Long
    
    arr = Array("LTD*", "MARIA1*", "<>*CSP", "<>*BTD")

    Set ws = ActiveSheet
    'range from A1 to last column header and last row
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With Application
             .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .DisplayStatusBar = False
            .EnableEvents = False
    End With
   
    With ws.Range("A1", ws.Cells(lr, lc))
        .HorizontalAlignment = xlCenter
        .AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
        If .Rows.Count - 1 > 0 Then
        On Error Resume Next
            .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
        On Error GoTo 0
            Else
                Exit Sub
        End If
    End With
      
    Workbooks("Predictology-Reports Football Advisor.xlsm").Sheets("Lay The Draw") _
          .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
    
    Application.CutCopyMode = False
End Sub

Any thoughts on what is wrong here?

cheers

 

[kevin9999]

The problem is you can't have more than 2 criteria with wildcards on the same field (column) with AutoFilter. There's a number of workarounds, the simplest in my opinion is to use Advanced Filter. Test the following code on a copy of your data to demonstrate how multiple criteria can work. It assumes your data starts in column A and that row 1 is a header row.

Option Explicit
Sub honkin()
    Dim rngList As Range, rngCriteria As Range, ws As Worksheet, LCol As Long, s
    
    Set ws = Worksheets("Sheet1")    '<< change to actual sheet name
    Set rngList = ws.Range("A1").CurrentRegion
    
    LCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column + 2
    ws.Cells(1).Copy ws.Range(ws.Cells(1, LCol), ws.Cells(1, LCol + 2))
    
    s = Array("LTD*", "MARIA1*")
    ws.Cells(2, LCol).Resize(2).Value = Application.Transpose(s)
    s = Array("<>*CSP", "<>*BTD")
    ws.Cells(2, LCol + 1).Resize(2, 2).Value = (s)
    
    Set rngCriteria = ws.Cells(1, LCol).CurrentRegion
    
    rngList.AdvancedFilter xlFilterInPlace, rngCriteria
    rngCriteria.ClearContents
End Sub

 

[kevin9999]

In case you wanted to try the copy function (as you seemed to want to in your first post)

Option Explicit
Sub honkin_V2()
    Dim rngList As Range, rngCriteria As Range, ws As Worksheet, LCol As Long, s
    
    Set ws = Worksheets("Sheet1")    '<< change to actual sheet name
    Set rngList = ws.Range("A1").CurrentRegion
    
    LCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column + 2
    ws.Cells(1).Copy ws.Range(ws.Cells(1, LCol), ws.Cells(1, LCol + 2))
    
    s = Array("LTD*", "MARIA1*")
    ws.Cells(2, LCol).Resize(2).Value = Application.Transpose(s)
    s = Array("<>*CSP", "<>*BTD")
    ws.Cells(2, LCol + 1).Resize(2, 2).Value = (s)
    
    Set rngCriteria = ws.Cells(1, LCol).CurrentRegion
    
    rngList.AdvancedFilter xlFilterInPlace, rngCriteria
    rngCriteria.ClearContents
    
    If ws.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
        With rngList
            .Offset(1).Resize(.Rows.Count - 1).Copy
            Workbooks("Predictology-Reports Football Advisor.xlsm").Sheets("Lay The Draw") _
                  .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With
    End If
    
    ws.ShowAllData
End Sub

 

[Peter_SSs]

I found it unclear from your thread title and attempted code to determine if you want to exclude items ending with "CSP" or "BTD" or exclude items containing "CSP" or "BTD".
Code below has gone with containing but removal of the appropriate asterisks would make it ending with.

So, if you want to persist with AutoFilter, you could try a modification like this for the AutoFilter part.

Dim i As Long
Dim arrData As Variant
Dim sData As String, sCrit As String


 With ws.Range("A1", ws.Cells(lr, lc))
        .HorizontalAlignment = xlCenter
        arrData = .Columns(1).Value
        For i = 1 To UBound(arrData)
          sData = LCase(arrData(i, 1))
          If sData Like "ltd*" Or sData Like "maria1*" Then
            If Not sData Like "*csp*" And Not sData Like "*btd*" Then sCrit = sCrit & "|" & arrData(i, 1)
          End If
        Next i
        .AutoFilter Field:=1, Criteria1:=Split(Mid(sCrit, 2), "|"), Operator:=xlFilterValues

 

[honkin]

In case you wanted to try the copy function (as you seemed to want to in your first post)

Option Explicit
Sub honkin_V2()
    Dim rngList As Range, rngCriteria As Range, ws As Worksheet, LCol As Long, s
   
    Set ws = Worksheets("Sheet1")    '<< change to actual sheet name
    Set rngList = ws.Range("A1").CurrentRegion
   
    LCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column + 2
    ws.Cells(1).Copy ws.Range(ws.Cells(1, LCol), ws.Cells(1, LCol + 2))
   
    s = Array("LTD*", "MARIA1*")
    ws.Cells(2, LCol).Resize(2).Value = Application.Transpose(s)
    s = Array("<>*CSP", "<>*BTD")
    ws.Cells(2, LCol + 1).Resize(2, 2).Value = (s)
   
    Set rngCriteria = ws.Cells(1, LCol).CurrentRegion
   
    rngList.AdvancedFilter xlFilterInPlace, rngCriteria
    rngCriteria.ClearContents
   
    If ws.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
        With rngList
            .Offset(1).Resize(.Rows.Count - 1).Copy
            Workbooks("Predictology-Reports Football Advisor.xlsm").Sheets("Lay The Draw") _
                  .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With
    End If
   
    ws.ShowAllData
End Sub

cheers kevin999

Thanks so much for your reply and the updated code.

I changed the sheet name and ran the macro and it copies only the required rows, but only copies to column C. That is quite possibly as column D is empty, as are G-K, but data goes across to L, so it needs to copy all the available data.

Here is what it looks like

predictology.csv
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	Name	Date	League		Event Name	Odds						Bet On
2	LTD4_HOME	11/12/22 6:00	Australia: A-League		Macarthur - Melbourne Victory	4.04						Draw
3	FAL7	11/12/22 11:30	Italy: Serie B		Cagliari - Perugia	5.31						Perugia
4	FAL8	11/12/22 11:30	Italy: Serie B		Cagliari - Perugia	5.31						Perugia
5	CSP4	11/12/22 11:30	Italy: Serie B		Cagliari - Perugia	1.37						Over 1.50 goals
6	CSP1	11/12/22 12:30	Romania: Liga I		Universitatea Cluj - UTA Arad	1.58						Over 1.50 goals
7	LTD1_HOME_BTD	11/12/22 12:30	Bel. First Division B		RWDM - Excelsior Virton	4.86						Draw
8	SHX_GOAL_KING_AWAY	11/12/22 12:45	Egypt: Premier League		Ghazl El Mehalla - El Daklyeh	2.3						Over 2.50 goals
9	LTD7_HOME_BTD	11/12/22 13:30	NL: Eerste Divisie		Jong Ajax - Jong Utrecht	3.92						Draw
10	CSP4	11/12/22 14:00	Italy: Serie B		Spal - Palermo	1.39						Over 1.50 goals
11	LTD1_HOME_CSP	11/12/22 16:00	Bel. First Division B		Beerschot-Wilrijk - Standard Liege II	1.14						Over 1.50 goals
12	LTD1_HOME_BTD	11/12/22 16:00	Bel. First Division B		Beerschot-Wilrijk - Standard Liege II	5.14						Draw
13	FAL7	11/12/22 17:30	Spain: Segunda		Eibar - Oviedo	5.78						Oviedo
14	FAL8	11/12/22 17:30	Spain: Segunda		Eibar - Oviedo	5.78						Oviedo
predictology

I hope that helps.

cheers

 

[kevin9999]

Try changing this line:

.Offset(1).Resize(.Rows.Count - 1).Copy

To this:

.Offset(1).Resize(.Rows.Count - 1, 12).Copy

Note the addition of the , 12

 

[Peter_SSs]

Did you try the alternate AutoFilter code?

 

[honkin]

I found it unclear from your thread title and attempted code to determine if you want to exclude items ending with "CSP" or "BTD" or exclude items containing "CSP" or "BTD".
Code below has gone with containing but removal of the appropriate asterisks would make it ending with.

So, if you want to persist with AutoFilter, you could try a modification like this for the AutoFilter part.

Dim i As Long
Dim arrData As Variant
Dim sData As String, sCrit As String


 With ws.Range("A1", ws.Cells(lr, lc))
        .HorizontalAlignment = xlCenter
        arrData = .Columns(1).Value
        For i = 1 To UBound(arrData)
          sData = LCase(arrData(i, 1))
          If sData Like "ltd*" Or sData Like "maria1*" Then
            If Not sData Like "*csp*" And Not sData Like "*btd*" Then sCrit = sCrit & "|" & arrData(i, 1)
          End If
        Next i
        .AutoFilter Field:=1, Criteria1:=Split(Mid(sCrit, 2), "|"), Operator:=xlFilterValues

Cheers Peter_SSs

Actually either exclude ending or containing will both work. Both CSP and BTD are at the end of any of the names, but both would do the job

I can play with this code in the autofilter section and see how it goes

Thanks again