Továbbfejlesztett keresés

Egy táblában, vagy annak egy sorában / oszlopában keresni egy adott értékre – makróval vagy anélkül – alapesetben nem bonyolult művelet, feltéve, hogy egyszerre csak egy értéket keresünk. De mi van, ha a művelet úgy hangzik, hogy “kettő, három vagy több érték bármelyikét keresd“? A való életben gyakran belefuthatunk ehhez hasonló problémába.

Vegyük példának a következő esetet:

Havonta készül egy táblázat, aminek egy bizonyos oszlopával (a példa kedvéért mondjuk az összeget tartalmazó oszlopával) szeretnénk valamilyen műveletet végezni. Mivel szeretnénk, ha a programunk rugalmasan kezelné az esetleges oszlop beszúrásokat, átrendezéseket, ezért nem égetjük be a programba, hogy mindig ugyanazzal az oszloppal (például mindig a 6. oszloppal) végezze a műveletet, hanem a programunk rákeres a fejlécben az oszlop elnevezésére (például arra, hogy “Összeg”), és amelyikben megtalálja, azzal az oszloppal végezzük a műveletet. Eddig tiszta sor, elég egyszerűen leprogramozható.
A bonyodalom ott kezdődik, hogy az általunk keresett oszlopot nem mindig ugyanúgy nevezi el a tábla készítője, hanem például valamikor “Összeg”, valamikor “Érték”, valamikor “HUF” elnevezés szerepel a fejlécben, hol kisbetűvel, hol nagybetűvel (természetesen ezen táblákat nem mi készítjük, mert ha mi készítenénk, akkor az elnevezés konzisztensen ugyanaz lenne).

Feltételezzük, hogy a lehetséges elnevezések köre változhat, kiegészülhet, és szeretnénk elkerülni, hogy minden ilyen alkalommal bele kelljen nyúlni a kódba, ezért a lehetséges elnevezéseket egy nevesített táblában tároljuk ez egyik Excel munkalapon, valahogy így:

A többváltozós keresés egyik kulcs momentumaként a lehetséges elnevezéseket betöltjük egy gyűjteménybe (Collection):

Sub Headers_Load (CollToLoad As Collection, TableName As String, TableHeader As String)

Dim FejlecSht As Worksheet
Dim tbl As ListObject
Dim c As Range

'   Tábla definiálása
    Set FejlecSht = Thisworkbook.Sheets("Sheet1")
    Set tbl = FejlecSht.ListObjects(TableName)

'   Gyűjtemény inicializálása és értékek betöltése
    Set CollToLoad = New Collection
    
    For Each c In tbl.ListColumns(TableHeader).DataBodyRange
        If not c.value="" Then CollToLoad.Add c.Value
    Next c

End Sub

Az eljárásnak az ezt meghívó eljárásból három paramétert adunk át:

• a gyűjteményt, amibe az értékeket töltjük
• a tábla nevét, amiben a lehetséges értékeket tároljuk
• a táblán belül az oszlop elnevezését, amiben a lehetséges értékeket tároljuk (arra az esetre, ha nem egy oszlopot keresnénk, hanem többet, és ennek az oszlopnak is meglennének a saját lehetséges elnevezései)

Első lépésként definiáljuk a táblát, amiben az elnevezések szerepelnek, ez jelen esetben a munkafüzetünk “Sheet1” elnevezésű lapján található. Ezután létrehozzuk a gyűjteményt, majd a tábla nevesített oszlopában szereplő értékeken egyenként végig megyünk (erre szolgál a For Each… ciklus), és amennyiben nem üres a cella, a cellában szereplő értéket betöltjük a gyűjteménybe.

Egy következő építőelem – jelen esetben egy függvény formájában – annak ellenőrzése, hogy egy adott érték egyezik-e a gyűjtemény bármelyik elemével:

Function FindCollectionElement(Coll As Collection, Val As Variant) As Boolean

Dim e As Variant    'gyűjtemény eleme
 
    FindCollectionElement = False

    For Each e In Coll
        If Not e = Empty And Val = e Then
            FindCollectionElement = True
            Exit Function
        End If
    Next e

End Function

A függvény input változói a gyűjtemény, amiben a lehetséges elnevezéseket tároljuk, valamint az érték, amit a gyűjtemény elemeihez hasonlítunk. A függvény a For Each…Next ciklussal végigmegy gyűjtemény elemein, és ellenőrzi, hogy az egyezik-e a vizsgált értékkel. Amennyiben egyezik, TRUE a függvény értéke, ellenkező esetben FALSE. Alapesetben a függvényben szereplő összehasonlítás (Val = e) FALSE értéket eredményez, amennyiben csak kisbetű-nagybetű eltérés van a két értékben. Hogy ezt kiküszöböljük – vagyis hogy az összehasonlítás hagyja figyelmen kívül a kisbetű-nagybetű különbséget -, az alábbi opciót írjuk a modul elejére, az eljárásokon kívül eső területre:

Option Compare Text

A harmadik összetevőnk szintén egy függvény, ami megadja, hogy a táblában hanyadik oszlopban szerepel a keresett érték:

Option Base 1

Function FindColumnByHeader (SourceTableArr As Variant, HeaderColl As Collection) As Integer

Dim col As Integer    'oszlop számláló

    FindColumnByHeader = 0

    For col = LBound(SourceTableArr, 2) To UBound(SourceTableArr, 2)

        If Not FindCollectionElement(HeaderColl, SourceTableArr(1, col)) = False Then
            FindColumnByHeader = col
        End If
        
        If Not FindColumnByHeader = 0 Then Exit For

    Next col

End Function

A függvény input változói a tábla, amiben keresünk – jelen esetben egy kétdimenziós tömb formájában -, valamint a lehetséges elnevezéseket tartalmazó gyűjtemény. A példánkban feltételezzük, hogy mindig a tábla első sora tartalmazza a fejlécet. A táblázak koordinátáinak könnyebb azonosíthatósága érdekében az “Option Base 1” opcióval beállítjuk, hogy a tömb hivatkozások 1-től induljanak, ne nullától.

A For…Next ciklussal végigmegyünk a tömb első sorában szereplő értékeken. Minden egyes értéknél meghívjuk a FindCollectionElement függvényt (vagyis ellenőrizzük, hogy a vizsgált érték egyezik-e a gyűjteményünk bármelyik elemével). Amennyiben ez az érték TRUE (vagyis van találat), a FindColumnByHeader függvényünk értéke a vizsgált értéket tartalmazó oszlop sorszáma lesz, és ezután ki is lépünk a ciklusból. Amennyiben nincs találat, a függvény értéke marad nulla, és a ciklusban továbblépünk a következő oszlopra.

Befejező mozzanatként alább található egy rövid teszt eljárás:

Sub Teszt ()

Dim HeaderColl as Collection
Dim SourceWB As Workbook
Dim SourceSheet As Worksheet
Dim SourceTableArr As Variant
Const sFullName As String = "C:\Temp\MintaTabla1.xlsx"

    Set HeaderColl = New Collection

    Call Headers_Load(HeaderColl, "Tábla1", "Összeg_Elnevezések")

'   Forrás fájl megnyitása
    Set SourceWB = Workbooks.Open(Filename:= sFullName)
'   Forrás lap betöltése
    Set SourceSheet = SourceWB.Sheets(1)
'   Forrás tábla beolvasása tömbbe
    SourceTableArr = SourceSheet.Range("A1").CurrentRegion.Value2

    If Not FindColumnByHeader (SourceTableArr, HeaderColl) = 0 Then
        MsgBox "A keresett oszlop sorszáma: " & FindColumnByHeader (SourceTableArr, HeaderColl)
    Else
        MsgBox "A keresett szövegek egyike sem található a fejlécben", vbCritical
    End If

End Sub

 

Első lépésben létrehozzuk az – egyelőre üres – gyűjteményt, majd a Headers_Load eljárással feltöltjük értékekkel azt. Itt adjuk meg, hogy a “Tábla1” elnevezésű táblában, az “Összeg_Elnevezések” elnevezésű oszlop tartalmazza a lehetséges elnevezéseket.
Következő lépésben megnyitjuk a – jelen példánkban egy konstans értékként definiált elérési útvonalon található – fájlt, majd annak első munkalapján szereplő táblát betöltjük a SourceTableArr elnevezésű tömbbe.
Harmadik lépésként meghívjuk a FindColumnByHeader függvényt. Amennyiben ennek értéke nulla (vagyis a tábla első sorában egyáltalán nem találtuk a gyűjtemény elemeinek egyikét sem, hibaüzenetet kapunk, egyéb esetben a szövegdobozban megjelenítjük a megtalált oszlop számát.

Végezetül álljon itt egyben a teljes program:

Option Explicit
Option Compare Text
Option Base 1

Sub Teszt ()

Dim HeaderColl as Collection
Dim SourceWB As Workbook
Dim SourceSheet As Worksheet
Dim SourceTableArr As Variant
Const sFullName As String = "C:\Temp\MintaTabla1.xlsx"

    Set HeaderColl = New Collection

    Call Headers_Load(HeaderColl, "Tábla1", "Összeg_Elnevezések")

'   Forrás fájl megnyitása
    Set SourceWB = Workbooks.Open(Filename:= sFullName)
'   Forrás lap betöltése
    Set SourceSheet = SourceWB.Sheets(1)
'   Forrás tábla beolvasása tömbbe
    SourceTableArr = SourceSheet.Range("A1").CurrentRegion.Value2

    If Not FindColumnByHeader (SourceTableArr, HeaderColl) = 0 Then
        MsgBox "A keresett oszlop sorszáma: " & FindColumnByHeader (SourceTableArr, HeaderColl)
    Else
        MsgBox "A keresett szövegek egyike sem található a fejlécben", vbCritical
    End If

End Sub

Sub Headers_Load (CollToLoad As Collection, TableName As String, TableHeader As String)

Dim FejlecSht As Worksheet
Dim tbl As ListObject
Dim c As Range

'   Tábla definiálása
    Set FejlecSht = Thisworkbook.Sheets("Sheet1")
    Set tbl = FejlecSht.ListObjects(TableName)

'   Gyűjtemény inicializálása és értékek betöltése
    Set CollToLoad = New Collection
    
    For Each c In tbl.ListColumns(TableHeader).DataBodyRange
        If not c.value="" Then CollToLoad.Add c.Value
    Next c

End Sub

Function FindCollectionElement(Coll As Collection, Val As Variant) As Boolean

Dim e As Variant    'gyűjtemény eleme
 
    FindCollectionElement = False

    For Each e In Coll
        If Not e = Empty And Val = e Then
            FindCollectionElement = True
            Exit Function
        End If
    Next e

End Function

Function FindColumnByHeader (SourceTableArr As Variant, HeaderColl As Collection) As Integer

Dim col As Integer    'oszlop számláló

    FindColumnByHeader = 0

    For col = LBound(SourceTableArr, 2) To UBound(SourceTableArr, 2)

        If Not FindCollectionElement(HeaderColl, SourceTableArr(1, col)) = False Then
            FindColumnByHeader = col
        End If
        
        If Not FindColumnByHeader = 0 Then Exit For

    Next col

End Function