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.

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í.

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…

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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

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

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.

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
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95

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

Příloha
soucet_dle_barvy.zip

Uložit článek jako PDF