Tartomány szűrése gépeléssel

A mai bejegyzés egyfajta érdekesség a szűrési technikák kapcsán.

Az első módszernél gépelés közben, szinte valós időben történik a szűrés (szövegdobozos változat). A másiknál a szöveg beírását majd az Enter lenyomását követően aktiválódik a filter.

Az adott munkafüzetben nyissuk meg a Visual Basic szerkesztőjét (VBE-t) ALT + F11-gyel. Majd kattintsunk duplán annak a munkalapnak a nevére, amelyhez a kódot hozzá szeretnénk adni. Például ha a “Munka1” nevű munkalapot választjuk: duplán kattintsunk “Munka1 (Munka1)”-re a VBE-ben:

Majd – miként a képen is látható – a jobb oldalon adjuk hozzá a kívánt kódot.

Makró az első módszerhez:

Option Explicit
Dim Ez As MSForms.TextBox

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

'a kódot tartalmazó munkalapon lévõ szövegdobozokba (text boxes) begépelt szöveg alapján történik a szûrés
'(gépelés közben!) az "A" és "B" oszlopokban

Private Sub TextBox1_Change()
Set Ez = TextBox1 'szövegdoboz eltárolása
Call EzKell(Ez)
End Sub

Private Sub TextBox2_Change()
Set Ez = TextBox2 'szövegdoboz eltárolása
Call EzKell(Ez)
End Sub

Sub EzKell(Kell As MSForms.TextBox)

Dim Tart As Range, Elem As OLEObject
                  
'ha mindkét oszlop ("A" és "B") le van szûrve és mondjuk csak az "A" oszlopban akarom a szûrést megszüntetni:
'"*"-ot kell használnom

'Kell.PasswordChar = "*" '"*"-ok jelennek meg a karakterek gépelésekor. Itt inkább csak érdekességként említem.

Set Tart = ActiveSheet.UsedRange 'a kódot a munkalaphoz adtuk hozzá, így NEM kell a teljes hivatkozást a munkalaphoz:
                                'ThisWorkbook.Worksheets("Sheet1").UsedRange

'szûrés a szövegdoboznál megadott (begépelt) szöveg alapján:
Tart.AutoFilter Right(Kell.Name, 1), "*" & Kell.Value & "*", xlFilterValues

'ha töröljük a szöveget az egyik szövegdobozban: törlõdik a másik szövegdobozban is
If Kell.Value = "" Then
    For Each Elem In ActiveSheet.OLEObjects
        If TypeName(Elem.Object) = "TextBox" Then Elem.Object.Text = ""
    Next Elem
    ActiveSheet.AutoFilterMode = False 'szûrõ kikapcsolása
End If

End Sub

Option Explicit

Dim Ez As MSForms.TextBox

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

'a kódot tartalmazó munkalapon lévõ szövegdobozokba (text boxes) begépelt szöveg alapján történik a szûrés

'(gépelés közben!) az "A" és "B" oszlopokban

Private Sub TextBox1_Change()

Set Ez = TextBox1 'szövegdoboz eltárolása

Call EzKell(Ez)

End Sub

Private Sub TextBox2_Change()

Set Ez = TextBox2 'szövegdoboz eltárolása

Call EzKell(Ez)

End Sub

Sub EzKell(Kell As MSForms.TextBox)

Dim Tart As Range, Elem As OLEObject

'ha mindkét oszlop ("A" és "B") le van szûrve és mondjuk csak az "A" oszlopban akarom a szûrést megszüntetni:

'"*"-ot kell használnom

'Kell.PasswordChar = "*" '"*"-ok jelennek meg a karakterek gépelésekor. Itt inkább csak érdekességként említem.

Set Tart = ActiveSheet.UsedRange 'a kódot a munkalaphoz adtuk hozzá, így NEM kell a teljes hivatkozást a munkalaphoz:

'ThisWorkbook.Worksheets("Sheet1").UsedRange

'szûrés a szövegdoboznál megadott (begépelt) szöveg alapján:

Tart.AutoFilter Right(Kell.Name, 1), "*" & Kell.Value & "*", xlFilterValues

'ha töröljük a szöveget az egyik szövegdobozban: törlõdik a másik szövegdobozban is

If Kell.Value = "" Then

For Each Elem In ActiveSheet.OLEObjects

If TypeName(Elem.Object) = "TextBox" Then Elem.Object.Text = ""

Next Elem

ActiveSheet.AutoFilterMode = False 'szûrõ kikapcsolása

End If

End Sub

Makró a második módszerhez:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Tart As Range, Ezt As Range

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

'a kódot tartalmazó munkalapon:
'az elsõ sor (fejléc) megfelelõ cellájába begépeljük a szûrési feltételt, majd ENTER-t nyomunk.
'A megadott szöveg alapján történik szûrés a releváns oszlopokban(A-D)

Set Tart = ActiveSheet.Range("A1:D1") 'Fejlécet tartalmazó cellák. "A1:D1"-et frissíteni ha szükséges

If Not Intersect(Target, Tart) Is Nothing Then
    Set Ezt = Target 'általunk módosított tartomány (ami itt az egyik cella az elsõ sorban) eltárolása
    Ezt.Select 'kell, különben az Enter lenyomása után az alatta lévõ cella lesz kiválasztva (és nem kell a CTRL+ENTER)
    Call EzKell(Ezt, Tart)
End If

End Sub

Sub EzKell(Ezt As Range, Tart As Range)

Dim Tart2 As Range

Set Tart2 = ActiveSheet.UsedRange 'a kódot a munkalaphoz adtuk hozzá, így NEM kell a teljes hivatkozást a munkalaphoz:
                                'ThisWorkbook.Worksheets("Sheet1").UsedRange

'ha mondjuk két oszlop ("A" és "B") le van szûrve és csak az "A" oszlopban akarom a szûrést megszüntetni:
'"*"-ot kell használnom

'szûrés az elsõ sorban megadott (begépelt) szöveg alapján:
Tart2.AutoFilter Ezt.Column, "*" & Ezt.Value & "*", xlFilterValues

'ha az elsõ sor (fejléc) egyik cellájának tartalmát töröljük:
If Ezt.Value = "" Then
    Application.EnableEvents = False
    ActiveSheet.AutoFilterMode = False 'szûrõ kikapcsolása
    Tart.ClearContents
    Application.EnableEvents = True
End If

End Sub

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Tart As Range, Ezt As Range

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

'a kódot tartalmazó munkalapon:

'az elsõ sor (fejléc) megfelelõ cellájába begépeljük a szûrési feltételt, majd ENTER-t nyomunk.

'A megadott szöveg alapján történik szûrés a releváns oszlopokban(A-D)

Set Tart = ActiveSheet.Range("A1:D1") 'Fejlécet tartalmazó cellák. "A1:D1"-et frissíteni ha szükséges

If Not Intersect(Target, Tart) Is Nothing Then

Set Ezt = Target 'általunk módosított tartomány (ami itt az egyik cella az elsõ sorban) eltárolása

Ezt.Select 'kell, különben az Enter lenyomása után az alatta lévõ cella lesz kiválasztva (és nem kell a CTRL+ENTER)

Call EzKell(Ezt, Tart)

End If

End Sub

Sub EzKell(Ezt As Range, Tart As Range)

Dim Tart2 As Range

Set Tart2 = ActiveSheet.UsedRange 'a kódot a munkalaphoz adtuk hozzá, így NEM kell a teljes hivatkozást a munkalaphoz:

'ThisWorkbook.Worksheets("Sheet1").UsedRange

'ha mondjuk két oszlop ("A" és "B") le van szûrve és csak az "A" oszlopban akarom a szûrést megszüntetni:

'"*"-ot kell használnom

'szûrés az elsõ sorban megadott (begépelt) szöveg alapján:

Tart2.AutoFilter Ezt.Column, "*" & Ezt.Value & "*", xlFilterValues

'ha az elsõ sor (fejléc) egyik cellájának tartalmát töröljük:

If Ezt.Value = "" Then

Application.EnableEvents = False

ActiveSheet.AutoFilterMode = False 'szûrõ kikapcsolása

Tart.ClearContents

Application.EnableEvents = True

End If

End Sub

Az alábbi videómban ismertetem a két módszer működését és a hozzájuk kapcsolódó VBA kódokat:

Zsolt visszajelzése adott inspirációt az alábbi kiegészítésre: mi van ha azt akarjuk, hogy már a munkalap kiválasztásakor aktív legyen a szövegdoboz? Utána pedig – az egér mellett – billentyűzettel szeretnénk váltogatni a szövegdobozok között? Nyissuk meg a Visual Basic szerkesztőjét (VBE-t) ALT + F11-gyel. Majd kattintsunk duplán annak a munkalapnak a nevére, mely az első makrót tartalmazza (itt: “Munka1” nevű munkalap). Adjuk hozzá a következő makrókat:

Private Sub Worksheet_Activate()
TextBox1.Activate 'TextBox1 lesz az aktív (kurzor ebben fog villogni)
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyTab Then 'ha a TextBox1 aktív és TAB-ot nyomok: a TextBox2 lesz az aktív (kurzor ebben fog villogni)
        TextBox2.Activate
    End If
End Sub

Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyTab Then 'ha a TextBox2 aktív és TAB-ot nyomok: a TextBox1 lesz az aktív (kurzor ebben fog villogni)
        TextBox1.Activate
    End If
End Sub

Private Sub Worksheet_Activate()

TextBox1.Activate 'TextBox1 lesz az aktív (kurzor ebben fog villogni)

End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

If KeyCode = vbKeyTab Then 'ha a TextBox1 aktív és TAB-ot nyomok: a TextBox2 lesz az aktív (kurzor ebben fog villogni)

TextBox2.Activate

End If

End Sub

Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

If KeyCode = vbKeyTab Then 'ha a TextBox2 aktív és TAB-ot nyomok: a TextBox1 lesz az aktív (kurzor ebben fog villogni)

TextBox1.Activate

End If

End Sub

A magyarázatot hozzáadtam a kódokhoz.

Remélem hasznos volt a poszt.
Mintafájlért illetve kérdésekkel kapcsolatosan szólj hozzá lent vagy dobj egy emailt: xlmotyo@gmail.com

Az első módszernél gépelés közben, szinte valós időben történik a szűrés (szövegdobozos változat). A másiknál a szöveg beírását majd az Enter lenyomását követően aktiválódik a filter.

Makró az első módszerhez:

Makró a második módszerhez:

Az alábbi videómban ismertetem a két módszer működését és a hozzájuk kapcsolódó VBA kódokat:

Ajánló