Tabulka obsluhovaná kódem VBA

V článku Tabulka aneb Seznam čili ListObject jsme se věnovali Tabulkám z pohledu práce na listu. Dnes si je osaháme prostřednictvím kódu VBA, kde jim není vyhrazen podle očekávání objekt Table, ale ListObject. Následující procedury najdete v přiloženém sešitu a doporučuji je odkrokovat při současném zobrazení listu s Tabulkou.

Tabulka pro VBA

Tabulka pro VBA

V kódu najdete hodně poznámek ohledně posunu buněk pod Tabulkou. K němu (ne vždy) dochází, pokud v Tabulce mažete/přidáváte řádky nebo měníte zobrazení Řádku souhrnů. Pokud toto řešit nechcete, tak se držte toho, co bylo řečeno posledně – do prostoru pod Tabulkou již nevkládejte žádné s ní nesouvisející hodnoty.

Sub TabulkaCasti()

    Dim wshList As Worksheet
    Dim loTabulka As ListObject

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")

    With loTabulka

        'celá tabulka
        .Range.Select

        'hlavička tabulky
        .HeaderRowRange.Select

        'datová část tabulky
        .DataBodyRange.Select

        'datová část tabulky (konstanty, tj. bez vzorců)
        .DataBodyRange.SpecialCells(xlCellTypeConstants).Select

        'druhý sloupec tabulky
        .ListColumns(2).Range.Select

        'datová část druhého sloupce tabulky
        .ListColumns(2).DataBodyRange.Select

        'třetí datový řádek tabulky
        .ListRows(3).Range.Select

        'řádek souhrnů (pokud je zobrazen)
        '.ShowTotals = True
        .TotalsRowRange.Select

    End With

End Sub
Sub TabulkaVlastnosti()

    Dim wshList As Worksheet
    Dim loTabulka As ListObject

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")

    With loTabulka

        'počet řádků včetně hlavičky (a řádku souhrnů)
        intPocetRadku = .Range.Rows.Count
       
        'počet datových řádků
        intPocetZaznamu = .ListRows.Count

    End With

End Sub
Sub TestBunkaTabulky()

    Dim rngBunka As Range
    Dim blnBunkaTabulky As Boolean
   
    Set rngBunka = ActiveCell

    On Error Resume Next

    'je buňka součástí Tabulky?
    blnBunkaTabulky = (rngBunka.ListObject.Name <> "")

    On Error GoTo 0
   
    If blnBunkaTabulky = True Then
   
        'výběr datové oblasti Tabulky, jíž je buňka součástí
        rngBunka.ListObject.DataBodyRange.Select
   
    End If

End Sub
Sub PridaniJednohoRadku()

    'zobrazení řádku souhrnů není na překážku
   
    Dim wshList As Worksheet
    Dim loTabulka As ListObject

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")

    With loTabulka

        'vložení nového řádku na konec tabulky
        .ListRows.Add
       
        'vložení nového řádku na konec tabulky
        'buňky pod tabulkou se neposunou
        .ListRows.Add AlwaysInsert:=False
        'pozn. Zobrazení/skrytí řádku souhrnů posouvá
        'buňky ležící pod Tabulkou vždy...
       
        'vložení nového řádku nad 3. záznam
        'tj. definujeme pozici nového řádku
        .ListRows.Add (3)

    End With

End Sub
Sub PridaniDatNaKonec()

    'Zack Barresse
   
    Dim wshList As Worksheet
    Dim loTabulka As ListObject
    Dim arrPridavanaData As Variant
    Dim inPocetRadku As Integer
    Dim intPocetSloupcu As Integer

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")
   
    'převzetí dat, zde z oblasti buněk do pole
    arrPridavanaData = wshList.Range("B20:D23").Value
   
    'rozměry datového bloku (pole)
    inPocetRadku = UBound(arrPridavanaData, 1)
    intPocetSloupcu = UBound(arrPridavanaData, 2)
   
    'nutné skrytí řádku souhrnů, pokud je zobrazen
    'pozor, dojde k posunu buněk ležících pod Tabulkou
    loTabulka.ShowTotals = False

    With loTabulka.DataBodyRange
        'přidání dat na konec Tabulky
        'neposouvá buňky ležící pod Tabulkou
        .Resize(inPocetRadku, intPocetSloupcu).Offset(.Rows.Count).Value = _
            arrPridavanaData
    End With

    'zobrazení řádku souhrnů
    'pozor, dojde k posunu buněk ležících pod Tabulkou
    'loTabulka.ShowTotals = True
   
    'oživení filtru
    If loTabulka.ShowAutoFilter = True Then
        loTabulka.AutoFilter.ApplyFilter
    End If

End Sub

Pozn. Řádek souhrnů je sice chytrý, ale někdy nám prostě překáží.

Sub VlozeniDat()
   
    'Zack Barresse
   
    Dim wshList As Worksheet
    Dim loTabulka As ListObject
    Dim arrPridavanaData As Variant
    Dim inPocetRadku As Integer
    Dim intPocetSloupcu As Integer

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")
   
    'převzetí dat, zde z oblasti buněk do pole
    arrPridavanaData = wshList.Range("B20:D23").Value
   
    'rozměry datového bloku (pole)
    inPocetRadku = UBound(arrPridavanaData, 1)
    intPocetSloupcu = UBound(arrPridavanaData, 2)
   
    With loTabulka.DataBodyRange
        'přidání dat mezi 5 a 6. řádek Tabulky
        'tj. pod 5. řádek
        'neposouvá buňky ležící pod Tabulkou
        .Resize(inPocetRadku).Offset(5).Insert Shift:=xlShiftDown
        .Resize(inPocetRadku, intPocetSloupcu).Offset(5).Value = _
            arrPridavanaData
    End With

    'oživení filtru
    If loTabulka.ShowAutoFilter = True Then
        loTabulka.AutoFilter.ApplyFilter
    End If

End Sub

Pokud se nepletu, Tabulku průvodci na listu nativně nabízejí pro zdroje dat z Microsoft Access, Microsoft Excel a pravděpodobně i z Microsoft SQL nebo třeba MySQL. V případě textových souborů (CSV) to trochu skřípe. Je otázka, zda-li jít cestou QueryTable či OLEDB (ADO, schema.ini). O tom ale zase někdy jindy. Nyní se podíváme na filtrování.

Sub TabulkaFiltr()
   
    Dim wshList As Worksheet
    Dim loTabulka As ListObject

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")
   
    'zapnutí/vypnutí filtru Tabulky
    'loTabulka.Range.AutoFilter
   
    'striktní obsah (Richtr)
    loTabulka.Range.AutoFilter Field:=1, Criteria1:="=Richtr"
   
    'striktní obsah (vše kromě položky Richtr)
    loTabulka.Range.AutoFilter Field:=1, Criteria1:="<>Richtr"
   
    'obsah (položky začínající na písmeno K)
    '? ... jeden znak, * ... žádný nebo více znaků
    loTabulka.Range.AutoFilter Field:=1, Criteria1:="=K*"
   
    'striktní obsah (Koch nebo Morávek)
    loTabulka.Range.AutoFilter Field:=1, Criteria1:="=Koch", Operator:=xlOr, _
        Criteria2:="=Morávek"
       
    'striktní obsah (Koch, Morávek, Sochor)
    loTabulka.Range.AutoFilter Field:=1, Criteria1:=Array("Koch", "Morávek", _
        "Sochor"), Operator:=xlFilterValues
    'není nástroj pro "vše kromě položek z následujícího výčtu"
    'lze řešit negací úlohy nebo přes rozšířený filtr, tzn.
    'OBCHODNIK   OBCHODNIK   OBCHODNIK
    '<>Koch      <>Morávek   <>Sochor
       
    'v případě datumu je nutný americký formát mm/dd/yyyy
    'a to bez ohledu na výstup ze Záznamníku maker
    'tj. např. Criteria1:=">=02/23/2015"
    'lze si pomoci funkcemi CLng, CDate
   
    'oživení filtru (po aktualizaci dat)
    'If loTabulka.ShowAutoFilter = True Then
    '    loTabulka.AutoFilter.ApplyFilter
    'End If

End Sub

Pozor na jednu nebezpečnou věc. V rámci filtru a parametru Criteria očekává Excel String a to i v případě čísel a testování rovnosti (regulérně bychom měli doplňovat znak „=“, např. Criteria1:=“=6″). Běžně si Excel s předaným číselným typem (Integer) poradí i bez uvedeného rovnítka, ale rozhodně tento stav nesmí nastat při užití Operator:= xlFilterValues. Jestliže takto definovanému filtru předhodíte jednu hodnotu číselného typu, tak Excel začne dělat psí kusy, přestane fungovat překreslování a aplikace nepůjde korektně zavřít. Jedná se podle mě o neošetřený stav a bug.

Sub ResetFiltruTabulky()

    Dim wshList As Worksheet
    Dim loTabulka As ListObject

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")

    'pokud Tabulka používá filtr...
    If loTabulka.ShowAutoFilter Then

        'pokud je filtr aktivní
        If loTabulka.AutoFilter.FilterMode Then

            'zobrazení všech dat
            loTabulka.AutoFilter.ShowAllData

        End If

    End If

End Sub

Pucování tabulky od dat lze řešit dvojím způsobem. Osobně jsem si oblíbil druhý z nich.

Sub VycisteniTabulky1()

    Dim wshList As Worksheet
    Dim loTabulka As ListObject

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")

    'vymazání všech datových řádků tabulky
    'nelze aplikovat na Tabulce bez datových řádků
    If loTabulka.ListRows.Count > 0 Then

        loTabulka.DataBodyRange.Delete
        'výsledek:
        'podobjekt DataBodyRange = Nothing
        'Tabulka zobrazuje jeden fiktivní datový řádek (bez vzorců)
        'Rows.Count = 2 pro hlavičku + fiktivní řádek
        'ale (!) ListRows.Count = 0
        'dojde k posunu buněk ležících pod Tabulkou

        'pro další práci je nutné přidat alespoň jeden řádek
        loTabulka.ListRows.Add
        'dojde k navrácení případných vzorců ve sloupcích
        'pozn. vzorce se uchovávají v ../xl/tables/table?.xml
        'buňky ležící pod Tabulkou se neposunou

    End If

End Sub
Sub VycisteniTabulky2()

    Dim wshList As Worksheet
    Dim loTabulka As ListObject

    Set wshList = Worksheets("Tabulka a VBA")
    Set loTabulka = wshList.ListObjects("MojeTabulka")

    'operace proběhnou jen na minimálně jednořádkové
    'vyplněné datové oblasti
    On Error Resume Next
   
    Application.ScreenUpdating = False
   
    With loTabulka.DataBodyRange
        'odstranění všech řádků kromě prvního
        .Resize(.Rows.Count - 1).Offset(1).Delete
        'vyčistění zbylého řádku od hodnot (vzorce ponechány)
        .SpecialCells(xlCellTypeConstants).ClearContents
    End With
   
    On Error GoTo 0
   
    Application.ScreenUpdating = True

End Sub

Příloha (váže se i k předchozímu článku):
tabulka.zip

Klikni a stahuj!