Szűrés kettőnél több feltételre

Ha kevés az időd és csak a videó érdekel, itt megtalálod.

A videóban prezentált makró lehetővé teszi, hogy kettőnél több szűrési feltételt (filter condition) adjunk meg egy tartománynál, mégpedig helyettesítő karakter (angolul joker vagy wildcard) használatával.

A kód úgymond lelke a Dictionary objektum (object), melyet itt nem mutatok be részletesen (a téma külön bejegyzést érdemelne), kizárólag az ide vonatkozó részt.
A Dictionary egyfajta gyűjtemény objektum (collection object). Az alábbiakat tartalmazhatja: szám (number), szöveg (text), dátum (date), tömb (array), tartomány (range) stb. Mivel kizárólag egyedi kulcsot (unique key) tartalmazhat, végigmehetünk egy tömb/tartomány/oszlop/sor stb elemein és egyedi, duplikációtól mentes értékeket kapunk vissza. Bár ennek az objektumnak nem ez a fő felhasználási módja, igen széles körben használják erre is.

Ezt a technikát alkalmaztam az “Értékek kinyerése az ismétlődések (pl. duplikációk) eltávolításával” posztomban is (7-es pont):
https://xlmotyo.hu/blog/ertekek-ismetlodes-eltavolitasa/

Jelen esetben az egyedi értékeket (kulcsokat) kell megkapnunk az első oszlopban, mely cikkszámokat tartalmaz. Ha a munkalap használt tartományát (used range) “Tart”-nak nevezzük, akkor végig kell mennünk annak sorain és beolvastatni az első oszlop értékeit a Dictionary objektumba:

For i = 2 To Tart.Rows.Count
    D(CStr(Tart.Cells(i, 1))) = "" 'beolvastatás
Next i

For i = 2 To Tart.Rows.Count

D(CStr(Tart.Cells(i, 1))) = "" 'beolvastatás

Next i

itt az egyedi érték (egyedi kulcs):

CStr(Tart.Cells(i, 1))

1	CStr(Tart.Cells(i, 1))

Példa:

Tart.Cells(1, 1)= 10862
Tart.Cells(2, 1)= 11430
Tart.Cells(3, 1)= 10862

Tart.Cells(1, 1)= 10862

Tart.Cells(2, 1)= 11430

Tart.Cells(3, 1)= 10862

Ez esetben az egyedi értékek ezek lennének: 10862 és 11430.

az egyedi érték listáját X-nek nevezzük…

X = D.keys

1	X = D.keys

… ezt követően pedig az egyedi értékeket az alábbi módon nyerhetjük ki:

For i = 0 To D.Count - 1
    MsgBox X(i), , ""
Next i

For i = 0 To D.Count - 1

MsgBox X(i), , ""

Next i

Az adott munkafüzetbe szúrjunk be egy modult a Visual Basic szerkesztőjében és az alábbi kódot adjuk hozzá:

Sub SzuresKettonelTobbFeltetelre()

Dim i As Long, j As Long, D As Object, D2 As Object, D3 As Object, Tart As Range
Dim Szuro, X, Y, Eleje As Long

'Készítette: XLMotyo (https://xlmotyo.hu)

'a makró lehetõvé teszi, hogy kettõnél több szûrési feltételt adjunk meg, mégpedig
'helyettesítõ karakter (angolul joker vagy wildcard) használatával

'a lenti kódnál a cikkszámoknak az általunk megadott számokkal kell kezdõdniük (szûrési listában levõ számokkal)

Application.ScreenUpdating = False

Set Tart = Worksheets("Munka1").UsedRange '"Munka1": frissíteni ha kell
Set D = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
Set D3 = CreateObject("scripting.dictionary")

'szûrõ kikapcsolása, ha be van kapcsolva:
If Worksheets("Munka1").AutoFilterMode = True Then Worksheets("Munka1").AutoFilterMode = False '"Munka1":frissíteni ha kell

' elsõ oszlop értékeinek beolvasása a Dictionary objektumba (duplikációkat kizárásával egyedi értékeket ad vissza):
For i = 2 To Tart.Rows.Count
    D(CStr(Tart.Cells(i, 1))) = ""
Next i

Eleje = 1
Ujra:
'Szûrési lista bekérése a felhasználótól:
Szuro = Application.InputBox("Add meg a szûrési listát, az elemeket vesszõvel elválasztva!", _
        "Cikkszámok ezekkel kezdõdjenek", "10,13,15", , , , , 1 + 2)

If Szuro = "" Then 'ha nem lett szûrési feltétel megadva
    MsgBox "Nem adtál meg szûrési feltételt, próbáld újra!", vbExclamation, ""
    GoTo Ujra
End If
    
If Szuro = False Then 'ha a felhasználó a jobb felsõ sarokban levõ X-re vagy a Mégse gombra kattintott vagy ESC-t nyomott
    MsgBox "Megszakítottad a folyamatot!", vbExclamation, ""
    Exit Sub
Else
    'Szûrési lista (Szuro) elemeinek kinyerése, majd beolvasása a Dictionary objektumba:
    Szuro = Trim(Replace(Szuro, " ", ""))
    For i = 1 To Len(Szuro)
        If Mid(Szuro, i, 1) = "," Or i = Len(Szuro) Then
            If Mid(Szuro, i, 1) <> "," And i = Len(Szuro) Then i = i + 1
            D2(Mid(Szuro, Eleje, i - Eleje)) = ""
            Eleje = i + 1
        End If
    Next i
    
    X = D.keys
    Y = D2.keys
    
    'közös elemek beolvasása Dictionary (D3) objektumba (D: elsõ oszlop értékei, D2: smegadott szûrési lista elemei)
    For i = 0 To D.Count - 1
        For j = 0 To D2.Count - 1
            If X(i) Like Y(j) & "*" Then D3(X(i)) = ""
        Next j
    Next i
    
    If D3.Count = 0 Then
        MsgBox "Nincs érték a megadott szûrési feltételekkel!", vbInformation, ""
        Exit Sub
    Else
        Tart.AutoFilter 1, D3.keys, xlFilterValues
    End If
End If

Application.ScreenUpdating = True

End Sub

Sub SzuresKettonelTobbFeltetelre()

Dim i As Long, j As Long, D As Object, D2 As Object, D3 As Object, Tart As Range

Dim Szuro, X, Y, Eleje As Long

'Készítette: XLMotyo (https://xlmotyo.hu)

'a makró lehetõvé teszi, hogy kettõnél több szûrési feltételt adjunk meg, mégpedig

'helyettesítõ karakter (angolul joker vagy wildcard) használatával

'a lenti kódnál a cikkszámoknak az általunk megadott számokkal kell kezdõdniük (szûrési listában levõ számokkal)

Application.ScreenUpdating = False

Set Tart = Worksheets("Munka1").UsedRange '"Munka1": frissíteni ha kell

Set D = CreateObject("scripting.dictionary")

Set D2 = CreateObject("scripting.dictionary")

Set D3 = CreateObject("scripting.dictionary")

'szûrõ kikapcsolása, ha be van kapcsolva:

If Worksheets("Munka1").AutoFilterMode = True Then Worksheets("Munka1").AutoFilterMode = False '"Munka1":frissíteni ha kell

' elsõ oszlop értékeinek beolvasása a Dictionary objektumba (duplikációkat kizárásával egyedi értékeket ad vissza):

For i = 2 To Tart.Rows.Count

D(CStr(Tart.Cells(i, 1))) = ""

Next i

Eleje = 1

Ujra:

'Szûrési lista bekérése a felhasználótól:

Szuro = Application.InputBox("Add meg a szûrési listát, az elemeket vesszõvel elválasztva!", _

"Cikkszámok ezekkel kezdõdjenek", "10,13,15", , , , , 1 + 2)

If Szuro = "" Then 'ha nem lett szûrési feltétel megadva

MsgBox "Nem adtál meg szûrési feltételt, próbáld újra!", vbExclamation, ""

GoTo Ujra

End If

If Szuro = False Then 'ha a felhasználó a jobb felsõ sarokban levõ X-re vagy a Mégse gombra kattintott vagy ESC-t nyomott

MsgBox "Megszakítottad a folyamatot!", vbExclamation, ""

Exit Sub

Else

'Szûrési lista (Szuro) elemeinek kinyerése, majd beolvasása a Dictionary objektumba:

Szuro = Trim(Replace(Szuro, " ", ""))

For i = 1 To Len(Szuro)

If Mid(Szuro, i, 1) = "," Or i = Len(Szuro) Then

If Mid(Szuro, i, 1) <> "," And i = Len(Szuro) Then i = i + 1

D2(Mid(Szuro, Eleje, i - Eleje)) = ""

Eleje = i + 1

End If

Next i

X = D.keys

Y = D2.keys

'közös elemek beolvasása Dictionary (D3) objektumba (D: elsõ oszlop értékei, D2: smegadott szûrési lista elemei)

For i = 0 To D.Count - 1

For j = 0 To D2.Count - 1

If X(i) Like Y(j) & "*" Then D3(X(i)) = ""

Next j

Next i

If D3.Count = 0 Then

MsgBox "Nincs érték a megadott szûrési feltételekkel!", vbInformation, ""

Exit Sub

Else

Tart.AutoFilter 1, D3.keys, xlFilterValues

End If

Application.ScreenUpdating = True

End Sub

Végezetül pedig a kapcsolódó videó egy továbbfejlesztett érdekességgel a végén:

Remélem hasznos volt a poszt.
Kérdésed, észrevételed van? Szólj hozzá lent vagy dobj egy emailt: xlmotyo@gmail.com

Szűrés kettőnél több feltételre

Ajánló