Jak vytvářet teplotní i jiné mapy

Ať už se díváte na rozložení teplot mapy ČR, zpracováváte model rozložení napětí s pomocí Metody konečných prvků nebo měříte elektromagnetické vlastnosti, potkáváte se s barevnými mapami. Ne, nebojte se, na tomto místě nehrozí žádný matematicko-fyzikální rozbor. Nám půjde o jinou věc – simulaci plošné mapy v prostředí Excelu.

V Excelu se můžeme vydat třemi cestami.

Povrchový (obrysový graf)

Mějme dvourozměrnou oblast o velikosti 20 x 20 buněk. Inspirací mi byl model RNDr. Ctibora Henzla a jeho příkladu z oblasti elektromagnetismu (pokud se pamatuji, jedná se o chování dielektrika určitého tvaru v elektrickém poli). Hodnoty zde uvedené jsou zadány přímo, abych neprozrazoval „know-how“ výpočtů. V daném modelu je totiž hodnota buňky závislá na okolních a je třeba se zamyslet nad cyklickými odkazy, iteracemi, … Mně osobně činilo problémy takový model dokázat nastartovat a oživovací proces připomínal spíš probouzení Golema. Zpátky ale k dětským hrám a „barvičkování“. První se nabízí povrchový (obrysový) graf.

Barevná mapa - povrchový graf

Barevná mapa – povrchový graf

Je vidět, že výsledek není ideální, ať už z pohledu vykreslování či barevnosti. Ani další nabízené styly těchto grafů nepočítají s barvami, na které jsme zvyklí, a jejich nahrazování ručně je neskutečná piplačka. Pokud na dané cestě chcete zůstávat, doporučuji sáhnout po VBA.

Obarvení buněk podmíněných formátem

Tato stezka je vyšlapaná i pro začátečníky a zvládne ji prakticky každý. Obarvení proběhne přímo na buňkách a postará se o něj průvodce v Podmíněném formátování. Ještě než jej aplikujete, doporučuji skrýt obsah buněk vlastním formátem ;;; (tři středníky). Když se později budete chtít podívat na hodnotu, přečtete ji v Řádku vzorců. Rastr buněk je čtvercový (buď se řiďte rozměry v pixelech nebo se přepněte do zobrazení Rozložení stránky).

Barevná mapa - podmíněný formát

Barevná mapa – podmíněný formát

U tohoto způsobu nevím, jestli jej doporučit jako číslo jedna nebo ne. První zdržení mohou v praxi představovat zmíněné výpočty vzorců v buňkách, které je poté nutno zpracovat podmíněným formátem… Na menším množství dat a při statických hodnotách je ale tento způsob rychlý. Navíc můžeme definovat vlastní barvy a hranice přechodů hodnotou, procentuálně, či vzorcem.

Obarvení buněk s pomocí VBA

Excel má přirozeně nejblíže k barevnému spektru reprezentovanému barvami červená-zelená-modrá (red-green-blue, RGB). Každá z nich nabývá hodnot 0-255. Čistá červená je tak zapsaná jako RGB(255, 0, 0). Jak na to ve VBA? V oblasti buněk najdeme minimální a maximální hodnotu (krajní hodnoty). V RGB modelu si vybereme dvě čisté barvy odpovídající krajním hodnotám a nastudujeme/vyzkoušíme si, jak musíme míchat složky barev, abychom docílili pěkného přechodu (modrá přes bílou do červené, zelená přes žlutou do červené apod.). Počet barev je v daném případě limitován v podstatě číslem 512 (256 z jedné čisté barvy do přechodové barvy a 256 z přechodové barvy do druhé čisté barvy). Do intervalu 1-512 barev pak musíme promítnout skutečné naměřené hodnoty (přepočty už byly řešeny v článku Více jak dvě svislé osy v grafu). Barvy ve VBA míchá funkce RGB a její výsledek přiřazujeme do vlastnosti .Interior.Color každé z buněk.

Barevná mapa - VBA (modrá-červená)

Barevná mapa – VBA (modrá-červená)

Barevná mapa - VBA (modrá-žlutá-červená)

Barevná mapa – VBA (modrá-žlutá-červená)

Barevná mapa - VBA (zelená-žlutá-červená)

Barevná mapa – VBA (zelená-žlutá-červená)

Private Const cstrOblast As String = "A1:T20"

Sub Spektrum2_ModraCervena()

    Dim i As Integer
    Dim aPoleRGB(1 To 256, 1 To 3) As Integer
    Dim rngBunka As Range
    Dim rngOblast As Range

    'Const intMinX As Integer = 0
    'Const intMaxX As Integer = 100

    Const intMinY As Integer = 0
    Const intMaxY As Integer = 255
   
    Set rngOblast = Range(cstrOblast)

    For i = 0 To 255

        aPoleRGB(i + 1, 1) = i
        aPoleRGB(i + 1, 2) = 0
        aPoleRGB(i + 1, 3) = 255 - i

    Next i

    intMinX = WorksheetFunction.Min(rngOblast)
    intMaxX = WorksheetFunction.Max(rngOblast)

    Application.ScreenUpdating = False
   
    For Each rngBunka In rngOblast
   
        x = rngBunka.Value

        y = CInt((intMaxY - intMinY) / (intMaxX - intMinX) * (x - intMinX) + intMinY)

        rngBunka.Interior.Color = RGB(aPoleRGB(y + 1, 1), aPoleRGB(y + 1, 2), aPoleRGB(y + 1, 3))
   
    Next rngBunka
   
    Application.ScreenUpdating = True

End Sub


Sub Spektrum3_ModraZlutaCervena()

    Dim i As Integer
    Dim aPoleRGB(1 To 512, 1 To 3) As Integer
    Dim rngBunka As Range
    Dim rngOblast As Range

    'Const intMinX As Integer = 0
    'Const intMaxX As Integer = 100

    Const intMinY As Integer = 1
    Const intMaxY As Integer = 512
   
    Set rngOblast = Range(cstrOblast)

    For i = 0 To 255
   
        aPoleRGB(i + 1, 1) = i
        aPoleRGB(i + 1, 2) = i
        aPoleRGB(i + 1, 3) = 255 - i

    Next i

    For i = 0 To 255

        aPoleRGB(i + 257, 1) = 255
        aPoleRGB(i + 257, 2) = 255 - i
        aPoleRGB(i + 257, 3) = 0
       
    Next i

    intMinX = WorksheetFunction.Min(rngOblast)
    intMaxX = WorksheetFunction.Max(rngOblast)

    Application.ScreenUpdating = False
   
    For Each rngBunka In rngOblast
   
        x = rngBunka.Value

        y = CInt((intMaxY - intMinY) / (intMaxX - intMinX) * (x - intMinX) + intMinY)

        rngBunka.Interior.Color = RGB(aPoleRGB(y, 1), aPoleRGB(y, 2), aPoleRGB(y, 3))
   
    Next rngBunka
   
    Application.ScreenUpdating = True

End Sub


Sub Spektrum3_ZelenaZlutaCervena()

    Dim i As Integer
    Dim aPoleRGB(1 To 512, 1 To 3) As Integer
    Dim rngBunka As Range
    Dim rngOblast As Range

    'Const intMinX As Integer = 0
    'Const intMaxX As Integer = 100

    Const intMinY As Integer = 1
    Const intMaxY As Integer = 512
   
    Set rngOblast = Range(cstrOblast)

    For i = 0 To 255
   
        aPoleRGB(i + 1, 1) = i
        aPoleRGB(i + 1, 2) = 128
        aPoleRGB(i + 1, 3) = 0

    Next i

    For i = 0 To 255

        aPoleRGB(i + 257, 1) = 255
        aPoleRGB(i + 257, 2) = 128 - i \ 2
        aPoleRGB(i + 257, 3) = 0
       
    Next i

    intMinX = WorksheetFunction.Min(rngOblast)
    intMaxX = WorksheetFunction.Max(rngOblast)

    Application.ScreenUpdating = False
   
    For Each rngBunka In rngOblast
   
        x = rngBunka.Value

        y = CInt((intMaxY - intMinY) / (intMaxX - intMinX) * (x - intMinX) + intMinY)

        rngBunka.Interior.Color = RGB(aPoleRGB(y, 1), aPoleRGB(y, 2), aPoleRGB(y, 3))
   
    Next rngBunka
   
    Application.ScreenUpdating = True

End Sub

Příloha:
excel_spektra.zip

Klikni a stahuj!