VBA Autofilter Method for Inventory List

[Jiwji]

Hello Experts,

i have tried to build my first VBA Project in Excel (Microsoft 365 Apps for Business, Version 2309 Build 16827.20166). The task is to create a searchable inventory list. Ive attached my project, but its all german so beware ;)
I tried to accomplish this by using the autofilter so the user can see every article all at once. (other then simple search by ctrl+f, where u only see the next entry and have to press enter to go to the next)

I have set up my excel file like this:

my Article names i want to search at are in B4:B. The user can enter a term in cell B2 as criteria for the autofilter. My macro gets called and my list gets filtered. This works everything as i want it to.

Now to my problem:

If the user enters more then one search term into cell B2, it doesnt quite work. It somehow depends on the order of the terms entered into B2.

For example:

if i enter "Tisch 140" into B2, the autofilter filters correctly and displays only articles witch contain "Tisch" and "140". but if i enter the terms the other way around, like "140 Tisch" then nothing gets displayed and every item is filterd out.

Another example: "Access Point" finds "Access Point, Lancom LW-600". But the searchterm "Point Access" doesnt find the same result.

This is the code im running to feed the autofilter the terms in B2 as the criteria.



Sub Suchen()
Dim ws As Worksheet
Dim Criteria As String
Dim CriteriaArray() As String
Dim i As Integer


Set ws = ThisWorkbook.Sheets("Inventur")


ws.Unprotect Password:="karl"


Criteria = Trim(ws.Range("B2").Value)


' Überprüfen, ob ein Wert ausgewählt wurde
If Criteria <> "" Then
' Teilen Sie die Suchbegriffe in ein Array auf
CriteriaArray = Split(Criteria, " ")


' Erstellen Sie ein Kriterium für die Filterung
Dim FilterCriteria() As String
For i = LBound(CriteriaArray) To UBound(CriteriaArray)
ReDim Preserve FilterCriteria(i)
FilterCriteria(i) = "*" & CriteriaArray(i) & "*"
Next i


' Verwenden Sie den xlAnd-Operator, um sicherzustellen, dass beide Begriffe vorhanden sind
Dim FinalCriteria As String
FinalCriteria = Join(FilterCriteria, "") ' Entfernen Sie Leerzeichen hier


ws.Range("B3").Value = FinalCriteria
ws.Range("B3").Interior.Color = RGB(252, 228, 214)


' Finde die letzte Zeile in Spalte A des Tabellenblatts "Inventur"
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row


' AutoFilter mit Operator xlFilterValues, um alle Kriterien gleichzeitig anzuwenden
ws.Range("$A$4:$G$" & LastRow).AutoFilter Field:=2, Criteria1:=FinalCriteria, Operator:=xlAnd


Call ZeilenZählenUndInLabelSchreiben
End If


ThisWorkbook.Sheets("Räume").Visible = xlSheetHidden
ws.Range("E3").Select
Sendkeys "{DOWN}", True


ws.Protect Password:="karl"
End Sub





Is it possible to ignore the order of the entered terms in B2 ?

thank you very much for your help

Greetings

[arnelgp]

here try this

[georgiboy]

Welcome to the forum,

Try forgetting your 'FinalCriteria' that is using the Join function, instead swap it for your 'FilterCriteria'

So change this:

ws.Range("$A$4:$G$" & LastRow).AutoFilter Field:=2, Criteria1:=FinalCriteria, Operator:=xlAnd
To this:

ws.Range("$A$4:$G$" & LastRow).AutoFilter Field:=2, Criteria1:=FilterCriteria, Operator:=xlAnd

[Jiwji]

here try this

thank you,

but now the results that are displayed contain only one of the words in B2. I want the search results to contain all of the entered terms, but the order shouldnt matter.

for example: searchterm "absperr rot" finds the article "Absperrkette rot", but also all other entries wich only contains the word "rot" like "

Brotkorb".

[Jiwji]

Welcome to the forum,

Try forgetting your 'FinalCriteria' that is using the Join function, instead swap it for your 'FilterCriteria'

So change this:

ws.Range("$A$4:$G$" & LastRow).AutoFilter Field:=2, Criteria1:=FinalCriteria, Operator:=xlAnd
To this:

ws.Range("$A$4:$G$" & LastRow).AutoFilter Field:=2, Criteria1:=FilterCriteria, Operator:=xlAnd


with your solution it does somehow matter in which order i type in the searchterms in B2. with different order i get different results.
"absperr rot" gives me 26 results, while "rot absperr" gives me only 5.
I want to display only entries that contain all entered searchterms, but the order should be irrelevant.

[georgiboy]

Try it as below:

ws.Range("$A$4:$G$" & LastRow).AutoFilter Field:=2, Criteria1:=FilterCriteria, Operator:=xlFilterValues

[Jiwji]

yeah thats the same solution arnelgp provided.
but as stated the results that are displayed contain only one of the words in B2.
I want the search results to contain all of the entered terms, but the order shouldnt matter.
"absperr rot" finds the article "Absperrkette rot", but also all other entries wich only contains the word "rot" like "Brotkorb"

[georgiboy]

Are you using Excel 365?

Ignore this, i was going to suggest a formula but i am guessing you want to update values after filtering?

Just for completeness i was going to offer the below formula:

=LET(
data,Sheet1!A1:G963,
ss,IF(ISNUMBER(SEARCH(" ",B2)),TEXTSPLIT(B2," "),B2),
fc,BYROW(N(ISNUMBER(IFERROR(SEARCH(ss,INDEX(data,,2)),""))),LAMBDA(x,SUM(x))),
FILTER(data,fc=COUNTA(ss))
)

[arnelgp]

try this again.

[georgiboy]

How many words do you plan to write in the 'Inventur' box?

[Jiwji]

try this again.

sorry to let you know, but still the same problem. only one of the entered searchterms is required to find results.
i attached a sample.

i typed "lancom access" but the formular finds also the entries with only one of the words in it.
i want the code to only find entries with both/all words from B2. So only "Access Point, Lancom LW-600" and "Access Point, Lancom LX-6400" should be displayed. 31170

[Jiwji]

Are you using Excel 365?

Ignore this, i was going to suggest a formula but i am guessing you want to update values after filtering?

Just for completeness i was going to offer the below formula:

=LET(
data,Sheet1!A1:G963,
ss,IF(ISNUMBER(SEARCH(" ",B2)),TEXTSPLIT(B2," "),B2),
fc,BYROW(N(ISNUMBER(IFERROR(SEARCH(ss,INDEX(data,,2)),""))),LAMBDA(x,SUM(x))),
FILTER(data,fc=COUNTA(ss))
)


thats quite a cool solution. The searchfunction does work exactly as i imagined.
But u guessed it: I want to update the values in Row E after filtering.
so first search for an article, then enter the realworld value in Row E; clear the list and search again.

And yea, the version im using is Microsoft 365 Apps for Business, Version 2309 Build 16827.20166.

[arnelgp]

here again for you to test.

[georgiboy]

On your worksheet 'Inventur' in cell: J1 - add the below formula:

=LET(
ts,"*"&TEXTSPLIT(B2," ")&"*",
rpt,TOROW(IF(SEQUENCE(,COUNTA(ts))<=COUNTA(ts),"Artikel",#N/A),3),
VSTACK(rpt,ts)
)


Then change your 'Suchen' sub to the below:

Sub Suchen()
Dim ws As Worksheet
Dim LastRow As Long
Dim rng As Range

Application.Calculation = xlCalculationManual

Set ws = ThisWorkbook.Sheets("Inventur")
ws.Unprotect Password:="karl"
LastRow = ws.UsedRange.Rows.Count
Set rng = ws.Range("A3:G" & LastRow)
rng.AdvancedFilter xlFilterInPlace
rng.AdvancedFilter xlFilterInPlace, ws.Range("J1#")
ThisWorkbook.Sheets("Räume").Visible = xlSheetHidden
ws.Range("E3").Select
Sendkeys "{DOWN}", True
ws.Protect Password:="karl"

Application.Calculation = xlCalculationAutomatic
End Sub

[Jiwji]

On your worksheet 'Inventur' in cell: J1 - add the below formula:

=LET(
ts,"*"&TEXTSPLIT(B2," ")&"*",
rpt,TOROW(IF(SEQUENCE(,COUNTA(ts))<=COUNTA(ts),"Artikel",#N/A),3),
VSTACK(rpt,ts)
)


Then change your 'Suchen' sub to the below:

Sub Suchen()
Dim ws As Worksheet
Dim LastRow As Long
Dim rng As Range

Application.Calculation = xlCalculationManual

Set ws = ThisWorkbook.Sheets("Inventur")
ws.Unprotect Password:="karl"
LastRow = ws.UsedRange.Rows.Count
Set rng = ws.Range("A3:G" & LastRow)
rng.AdvancedFilter xlFilterInPlace
rng.AdvancedFilter xlFilterInPlace, ws.Range("J1#")
ThisWorkbook.Sheets("Räume").Visible = xlSheetHidden
ws.Range("E3").Select
Sendkeys "{DOWN}", True
ws.Protect Password:="karl"

Application.Calculation = xlCalculationAutomatic
End Sub


cant get my head around it, but i didnt get it to work.. maybe cause i use the german version of excel ?! tried to translate the commands but i always get the error that the formular doesnt work.

[Jiwji]

31175
On your worksheet 'Inventur' in cell: J1 - add the below formula:

=LET(
ts,"*"&TEXTSPLIT(B2," ")&"*",
rpt,TOROW(IF(SEQUENCE(,COUNTA(ts))<=COUNTA(ts),"Artikel",#N/A),3),
VSTACK(rpt,ts)
)


Then change your 'Suchen' sub to the below:

Sub Suchen()
Dim ws As Worksheet
Dim LastRow As Long
Dim rng As Range

Application.Calculation = xlCalculationManual

Set ws = ThisWorkbook.Sheets("Inventur")
ws.Unprotect Password:="karl"
LastRow = ws.UsedRange.Rows.Count
Set rng = ws.Range("A3:G" & LastRow)
rng.AdvancedFilter xlFilterInPlace
rng.AdvancedFilter xlFilterInPlace, ws.Range("J1#")
ThisWorkbook.Sheets("Räume").Visible = xlSheetHidden
ws.Range("E3").Select
Sendkeys "{DOWN}", True
ws.Protect Password:="karl"

Application.Calculation = xlCalculationAutomatic
End Sub


wow, this one does almost work like i imagined. Your code just created another bug :D

you can see in my screenshot that i have another filter for "Raum" (Room) - the yellow/orange section to the right. i want to be able to filter after Artikel (Article) and/or Raum (Room) at the same time.

so if i set a filter for "Raum" like in the screenshot (Fahnenraum), then i want the normal searchfunction to only search inside that filtered list. So only search inside that room as you could say.

this did work in my previous code, but now it doesnt anymore.

i guess its because you use


If ws.FilterMode Then ws.ShowAllData

at the start of your code, so it does remove my yellow "Raum-filter".

I tried to remove this line from your code, but after some missspelled entries in the searchbox B2 with an active "Raum-filter" i get the Runtimerror "3265 item cannot be found in the collection corresponding to the requested name or ordinal (https://stackoverflow.com/questions/69718822/excel-vba-run-time-error-3265-item-cannot-be-found-in-the-collection-correspondi)"

debugging goes to that line here.


adoRecordset.Filter = strCriteria


thank you, were getting somewhere here. nice help

[georgiboy]

Your code just created another bug http://www.vbaexpress.com/forum/images/smilies/astrosmiley.gif
Think it is more a case of the goalposts moving ;)


Edit the formula in cell J1 to:

=LET(
tsOne,"*"&TEXTSPLIT(B2," ")&"*",
rptOne,TOROW(IF(SEQUENCE(,COUNTA(tsOne))<=COUNTA(tsOne),"Artikel",#N/A),3),
tsTwo,"*"&TEXTSPLIT(F2," ")&"*",
rptTwo,TOROW(IF(SEQUENCE(,COUNTA(tsTwo))<=COUNTA(tsTwo),"Standard Raum",#N/A),3),
fOne,VSTACK(rptOne,tsOne),
ftwo,VSTACK(rptTwo,tsTwo),
res,HSTACK(IFERROR(fOne,""),IFERROR(ftwo,"")),
FILTER(res,NOT(ISNA(INDEX(res,2))))
)

Please note that the values in the headers (row 3) need to stay as they are, if you change them then the advanced filter will break.

[arnelgp]

ok amended the code to include the combo.

[Jiwji]

sorry for the late reply. work takes alot of my headspace right now..
the latest answers were really helpfull. im still trying to figure out some things and how they work/not work - especially for self teaching and the learning effect.
ill try to sort thru things the next days and get back to this vba project.
thanks guys