Součet buněk dle barvy

Součet buněk dle barvy (pozadí) patří k nejčastějším zadáním objevující se na internetových fórech. Dodnes není uspokojivě vyřešen z pohledu funkcí listu. Na druhou stranu buďme rádi za přidanou funkčnost v automatickém filtru, jíž si ukážeme posléze. Ještě předtím ale pár slov k tématu obecně.

Při každé příležitosti zdůrazňuji:
1) Smysl má barvit pozadí buňky, barva písma (ať už definovaná ručně, vlastním formátem buňky nebo podmíněným formátováním) se velmi špatně zrakem rozlišuje, pokud se nejedná o základní barvu a není dostatečně kontrastní s pozadím buňky
2) Veškeré barvičkování končí černobílou laserovou tiskárnou, kdy se slijí barvy s podobnou „sytostí“ do jednoho odstínu šedé. V grafech vám pak nepomůže ani legenda. Ne nadarmo byli uživatelé nešťastní, když nakrátko zmizely možnosti výplní grafů typu šrafování apod. U spojnic doporučuji rozlišovat nejen barvu čáry, ale i její typ. Na listu by teoreticky pomohlo ohraničení buňky, ale takový způsob je prostě tfujtajblový.
3) I když máte možnost barevného tisku, odstín barvy na monitoru a po tisku se bude lišit. Podstatnější ovšem je, že nemalá část populace trpí barvoslepostí (test) a dalšími očními neduhy, nemluvě o klasickém problému vnímání barev (zelená/modrá apod.).
4) Excel 2003 a starší nemá žádný nástroj pro práci s buňkami na základě barvy kromě možností v dialogu Najít a nahradit.

Dialog Najít a nahradit

Už v základech Excelu říkám „klepněte si na tlačítko Možnosti v dialogu Najít a nahradit“. Rozbalí se nabídka dalších nástrojů, mezi nimiž je i možnost vyhledávání buněk na základě formátu. Pokud se přepnete na záložku Nahradit, pak můžete snadno buňky i přebarvovat.

Dialog Najít a nahradit - hledání dle formátu

Dialog Najít a nahradit – hledání dle formátu

Podstatná je ve vztahu k dnešnímu tématu jedna technika. Jestliže zvolíte Najít vše a ve výpisu stisknete CTRL+A, vyberou se nejen všechny položky v seznamu, ale i odpovídající buňky na listu! Po zavření dialogu se tak můžete podívat do stavového řádku řekněme na součet.

Pozn. Nezapomínejte před ukončením práce s dialogem resetovat nastavení formátu (Volba Vymazat pole pro hledání formátu).

Tento způsob práce s barevnými buňkami jednoduše nemohl chybět, i když v daném případě nelze mluvit o nějaké efektivní práci.

Automatický filtr

Klíčem k řešení úlohy za pomoci vestavěných nástrojů je skutečnost, že novodobé verze Excelu již umí filtrovat dle barvy pozadí (i písma), dokonce si poradí i s obarvením vzniklým podmíněným formátem. Nad takto přefiltrovaným sloupcem pak stačí nasadit funkci SUBTOTAL s potřebnou matematickou operací.

Automatický filtr - filtrování dle barvy

Automatický filtr – filtrování dle barvy

Pokud barevné buňky nejsou rozházené po celém listu, ale řešíme danou problematiku v rámci sloupců seznamu, pak je automatický filtr nejefektivnější metodou pro součet buněk dle barvy (a nejen součet, viz první parametr funkce SUBTOTAL).

Vlastní funkce VBA

Jak bylo řečeno, před příchodem Excelu 2007 neexistoval žádný rozumný způsob řešení úlohy bez VBA. Starší verze jednoduše neuměly filtrovat buňky podle barvy. Uvažujeme-li o řešení ve Visual Basicu pro aplikace, pak je třeba si uvědomit, že změna barvy buňky nevyvolá událost Change (změna obsahu buňky), ani Calculate (přepočet listu). I když si tedy vytvoříme vlastní funkci listu (UDF) a přinutíme ji být tzv. Volatile, přepočte se až v momentě jinak vzniklé potřeby přepočtu listu, případně při ručně vynuceném přepočtu (např. klávesou F9). A bohužel, pod VBA je velmi obtížné zjišťovat barvu coby výsledek podmíněného formátování. Prakticky dodnes se uplatňuje způsob, s jakým přišel Chip Pearson (přečtěte si články Color Functions In Excel a Conditional Formatting Colors. V podstatě procházíme všechny větve podmíněných formátů a testujeme, zda-li je v danou chvíli podmínka platná. Musíme zohlednit, že barva podmíněného formátování má přednost před ručně definovanou barvou, navíc u podmíněných formátů záleží na pořadí a „stopce“. Zpracování takové funkčnosti jsem se s prominutím vyhnul, níže uvedená vlastní funkce pracuje pouze s ručně definovanými barvami. Chápu, že tím ztrácí na kráse a užitné hodnotě, ale…

Function epfFUNKCEBARVA(Oblast As Range, RefBunka As Range, Optional Operace As _
    String = "součet") As Double

    Dim rngBunka As Range

    Dim arrPoleHodnot()

    Dim lngBarva As Long
    Dim i As Long

    Dim dblHodnota As Double

    'funkce zareaguje na přepočet listu (nikoliv na obarvení buňky)
    Application.Volatile

    'barva pozadí referenční buňky
    lngBarva = RefBunka.Interior.Color

    'přeskočení chyb
    On Error Resume Next

    'dimenzování pole
    ReDim arrPoleHodnot(1 To Oblast.Cells.Count)

    'pro každou buňku v oblasti
    For Each rngBunka In Oblast

        'shoduje se barva pozadí buňky s referenční barvou
        'a obsahuje číselnou hodnotu (může být i datum...)?
        If (rngBunka.Interior.Color = lngBarva) And (IsNumeric(rngBunka.Value)) _
            Then

            'počítadlo
            i = i + 1

            'přidání číselného obsahu do součtu
            arrPoleHodnot(i) = rngBunka.Value

        End If

    Next rngBunka

    Select Case LCase(Operace)

        Case "počet"

            epfFUNKCEBARVA = WorksheetFunction.Count(arrPoleHodnot)

        Case "součet"

            epfFUNKCEBARVA = WorksheetFunction.Sum(arrPoleHodnot)

        Case "průměr"

            epfFUNKCEBARVA = WorksheetFunction.Average(arrPoleHodnot)

        Case "minimum"

            epfFUNKCEBARVA = WorksheetFunction.Min(arrPoleHodnot)

        Case "maximum"

            epfFUNKCEBARVA = WorksheetFunction.Max(arrPoleHodnot)

    End Select

End Function

Funkce pracuje pouze s pozadím buňky. Očekává dva povinné argumenty – sčítanou oblast a referenční buňku s barvou, a jeden nepovinný – operaci prováděnou na hodnotách odpovídajících buněk. Součet buněk dle barvy nemusí být jedinou potřebnou operací, proto byl přidán i počet číselných buněk, průměr, minimum a maximum. Není problém za pomoci funkcí listu (WorksheetFunction) doplnit další.

Vlastní funkce pro práci s barevnými buňkami

Vlastní funkce pro práci s barevnými buňkami

Na závěr bych doplnil ještě jednu proceduru pro případ, kdy nám jde pouze o seznam buněk s uvedením počtu jejich výskytu v dané oblasti. Kód využívá objekt Dictionary a jeho vlastnosti ověřovat si duplicitní výskyt položky.

Sub Barvy()

    'Tools / References / Microsoft Scripting Runtime

    Dim objDic As New Dictionary

    Dim rngBunka As Range
    Dim rngOblast As Range

    Dim strHlaska As String
    Dim strTitulek As String

    Dim lngBarva As Long
    Dim i As Integer

    Dim PoleKlice()
    Dim PolePolozky()

    'texty v dialogu
    strHlaska = "Myší označte jednosloupcovou, spojitou oblast buněk."
    strTitulek = "Zpracovávaná oblast"

    'přechod na další řádek v případě, že se nepodaří
    'přiřazení oblasti do objektové proměnné
    On Error Resume Next

    'vlastní pokus o přiřazení oblasti z dialogu do objektové proměnné
    Set rngOblast = Application.InputBox(strHlaska, strTitulek, _
        Selection.Address, , , , , 8)

    'opuštění procedury v případě chyby
    If Err <> 0 Then Exit Sub

    'pro každou buňku v oblasti
    For Each rngBunka In rngOblast

        On Error Resume Next

        'přiřazení barvy buňky do proměnné
        lngBarva = rngBunka.Interior.Color

        'existuje záznam o barvě v knihovně?
        If objDic(lngBarva).Exists = True Then

            'ano, navýšit informaci o počtu výskytů
            objDic(lngBarva) = objDic(lngBarva) + 1

        Else

            'ne, přidat záznam o barvě a informaci o prvním výskytu
            objDic.Add lngBarva, 1

        End If

    Next rngBunka

    'přenos klíčů a hodnot z objektu knihovny do polí
    PoleKlice = objDic.Keys
    PolePolozky = objDic.Items

    'texty v dialogu
    strHlaska = "Myší označte počátek vložení výsledku."
    strTitulek = "Cílová oblast"

    'přechod na další řádek v případě, že se nepodaří
    'přiřazení oblasti do objektové proměnné
    On Error Resume Next

    'vlastní pokus o přiřazení oblasti z dialogu do objektové proměnné
    Set rngOblast = Application.InputBox(strHlaska, strTitulek, , , , , , 8)

    'opuštění procedury v případě chyby
    If Err <> 0 Then Exit Sub

    'zamezení překreslování obrazovky
    Application.ScreenUpdating = False

    'pro každou buňku v cílové oblasti
    For Each rngBunka In rngOblast.Cells(1).Resize(UBound(PoleKlice) + 1, 1)

        'počítadlo
        i = i + 1

        'přiřazení barvy buňce z pole s klíči
        rngBunka.Interior.Color = PoleKlice(i - 1)

        'přiřazení hodnoty do buňky
        rngBunka.Value = PolePolozky(i - 1)

    Next rngBunka

    'povolení překreslování obrazovky
    Application.ScreenUpdating = True

End Sub
Výčet barevných buněk

Výčet barevných buněk

Příloha
soucet_dle_barvy.zip

Klikni a stahuj!