Tabulka obsluhovaná kódem VBA

Úvodní stránka | Blog | Excel VBA | 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.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    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
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    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
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    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
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    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
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    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áží.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    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í.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    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.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    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.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    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
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    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

    Uložit článek jako PDF