Efektivní přebarvení oblasti buněk

Berete do ruky svou pár let starou šablonu nebo sešit klienta, jehož barevná koncepce a štábní kultura pokulhává a chystáte se ho přebarvit? Tušíte, že to bude práce na dlouhé minuty, ne-li hodiny? Zkusím vám práci trochu zpříjemnit a především zkrátit.

Ergonomie novodobých Excelů s Pásem karet nám moc nepomáhá. Zatímco dříve bylo možné patřičné panely pro barvy a ohraničení možné odtrhnout a mít je k dispozici jako plovoucí dialogy na jedno klepnutí myši, dnes je především přístup k nástrojům ohraničení otravný. Přitom ruční kreslení ohraničení patřilo k neprávem opomíjeným technikám.

Panely pro práci s barvami a ohraničením v Excelu 2003 a 2010

Panely pro práci s barvami a ohraničením v Excelu 2003 a 2010

S tímhle už dnes v Excelu prostě nepochodíte…

Sub Excel2003()

    'panely Barva výplně, Barva písma a Ohraničení
    Application.CommandBars("Fill Color").Visible = True
    Application.CommandBars("Font Color").Visible = True
    Application.CommandBars("Borders").Visible = True

End Sub

Můžete namítat, že Excel 2007 jako první přinesl rozšířenou paletou barev a lepší práci s motivy. Osobně to vidím spíš jako barevný povyk pro nic, který byl převzat z okrajově používaného Publisheru. Pro přebarvení nám nebude moc platná ani skupina Motivy na kartě Rozložení stránky, ani Styly na kartě Domů. Potřebujeme něco víc.

Je škoda, že uživatelé pořádně neznají možnosti dialogu Najít/Nahradit (CTRL+F, CTRL+H). Většina z nich nikdy neklepla myškou na tlačítko Možnosti…

Najít a nahradit - Formát

Najít a nahradit – Formát

Pozn. Dobrým zvykem je před uzavřením dialogu vymazat formátování (rozklepněte tlačítko Formát, volba Vymazat pole pro hledání formátu). Programové zpracování by mohlo vypadat nějak takto:

Sub ZmenaBarevnostiPozadi()
    With Application
        'najít barvu pozadí buňky (červená)
        .FindFormat.Interior.ColorIndex = 3
        'zaměnit za barvu (fialová)
        .ReplaceFormat.Interior.ColorIndex = 13
    End With
    'vlastní záměna pro výběr buněk
    Selection.Replace What:="", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=True, _
        ReplaceFormat:=True
    'odstranění nastavení formátů pro vyhledávání
    With Application
        .FindFormat.Clear
        .ReplaceFormat.Clear
    End With
End Sub

Sub ZmenaBarevnostiOhraniceni()
    With Application
        'najít barvu ohraničení buňky (červená)
        .FindFormat.Borders.ColorIndex = 3
        'zaměnit za barvu (fialová)
        .ReplaceFormat.Borders.ColorIndex = 13
    End With
    'vlastní záměna pro výběr buněk
    Selection.Replace What:="", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=True, _
        ReplaceFormat:=True
    'odstranění nastavení formátů pro vyhledávání
    With Application
        .FindFormat.Clear
        .ReplaceFormat.Clear
    End With
End Sub

Výpis VBA výše ukazuje práci s vlastností ColorIndex, která je vlastní základní barevné paletě z Excelu 2003. Na sešity novodobých verzí Excelu doporučuji aplikovat vlastnost Color.

Pozor na jednu věc. Řekněme, že existuje zelené svislé ohraničení mezi sousedícími buňkami C7 a D7. Excelu není jedno, jestli k němu fyzicky došlo obarvením pravé hrany buňky C7 nebo levé hrany buňky D7, i když pro oko je výsledek stejný. Evidentní je tento rozdíl v případě, že v daném místě dojde k zalomení stránky. Ohraničení se pak zobrazí u té buňky, na které bylo skutečně užito.

Pořád to není ale to pravé ořechové, že? Co když chceme nahradit všechny výskyty červené barvy u všech typů ohraničení naráz? Jistě, máme tu VBA…

Následující proceduru jsem sestavil co nejuniverzálnější. Očekává, že uživatel vybere oblast pro záměnu barevnosti, následně referenční buňky s původními a novými barvami, a zeptá se ještě na typ objektu pro přebarvení (0 … vše, 1 … písmo, 2 … pozadí, 3 … ohraničení). Zde už pracuji s vlastností Color.

Sub ZmenaBarevnosti()

    Dim strRev As String
    Dim rngBunka As Range
    Dim rngRefOblast1 As Range
    Dim rngRefOblast2 As Range
    Dim iCil As Byte
    Dim iPocetBarev As Integer
    Dim aPoleBarvy()

    On Error Resume Next

    'oblast pro přebarvení
    Set rngOblast = Application.InputBox("Vyberte oblast pro přebarvení.", _
        "Zpracovávaná oblast", Selection.Address(0, 0), , , , , 8)
    If Err <> 0 Then Exit Sub

    'referenční buňka s původní (hledanou) barvou
    Set rngRefOblast1 = _
        Application.InputBox("Vyberte referenční buňky s původními barvami.", _
        "Referenční oblast 1", Selection.Address(0, 0), , , , , 8)
    If Err = 0 Then

        iPocetBarev = rngRefOblast1.Cells.Count

        ReDim aPoleBarvy(1 To iPocetBarev, 1 To iPocetBarev)

        For i = 1 To iPocetBarev
            'původní barvy
            aPoleBarvy(i, 1) = rngRefOblast1.Cells(i).Interior.Color
        Next i

    Else
        Exit Sub
    End If

    'referenční buňka s nově aplikovanou barvou
    Set rngRefOblast2 = _
        Application.InputBox("Vyberte referenční buňky s novými barvami.", _
        "Referenční oblast 2", rngRefOblast1.Offset(0, 1).Address(0, 0), , , , , 8)
    If Err = 0 Then
   
        For i = 1 To iPocetBarev
            'nové barvy
            aPoleBarvy(i, 2) = rngRefOblast2.Cells(i).Interior.Color
        Next i
       
    Else
        Exit Sub
    End If

    'cíl přebarvení (0 ... vše, 1 ... písmo, 2 ... pozadí, 3 ... ohraničení))
    strRev = Application.InputBox(Title:="Cíl přebarvení", _
        Prompt:="0 ... vše, 1 ... písmo, 2 ... pozadí, 3 ... ohraničení", _
        Default:="0", Type:=2)

    If strRev = "False" Then
        Exit Sub
    Else
        iCil = Val(strRev)
    End If

    Application.ScreenUpdating = False

    For i = 1 To iPocetBarev

        For Each rngBunka In rngOblast.Cells

            With rngBunka

                If iCil = 1 Or iCil = 0 Then
                    If rngBunka.Font.Color = aPoleBarvy(i, 1) Then
                        'barva písma
                        rngBunka.Font.Color = aPoleBarvy(i, 2)
                    End If
                End If

                If iCil = 2 Or iCil = 0 Then
                    If rngBunka.Interior.Color = aPoleBarvy(i, 1) Then
                        'barva pozadí
                        rngBunka.Interior.Color = aPoleBarvy(i, 2)
                    End If
                End If

                'Borders.Color vrací Null,
                'pokud všechna ohraničení nemají stejnu barvu

                If iCil = 3 Or iCil = 0 Then
                    'barva horního ohraničení
                    With .Borders(xlEdgeTop)
                        If .Color = aPoleBarvy(i, 1) Then
                            .Color = aPoleBarvy(i, 2)
                        End If
                    End With

                    'barva pravého ohraničení
                    With .Borders(xlEdgeRight)
                        If .Color = aPoleBarvy(i, 1) Then
                            .Color = aPoleBarvy(i, 2)
                        End If
                    End With

                    'barva dolního ohraničení
                    With .Borders(xlEdgeBottom)
                        If .Color = aPoleBarvy(i, 1) Then
                            .Color = aPoleBarvy(i, 2)
                        End If
                    End With

                    'barva levého ohraničení
                    With .Borders(xlEdgeLeft)
                        If .Color = aPoleBarvy(i, 1) Then
                            .Color = aPoleBarvy(i, 2)
                        End If
                    End With

                    'barva ohraničení hlavní diagonály
                    With .Borders(xlDiagonalDown)
                        If .Color = aPoleBarvy(i, 1) Then
                            .Color = aPoleBarvy(i, 2)
                        End If
                    End With

                    'barva ohraničení vedlejší diagonály
                    With .Borders(xlDiagonalUp)
                        If .Color = aPoleBarvy(i, 1) Then
                            .Color = aPoleBarvy(i, 2)
                        End If
                    End With

                End If

            End With

        Next rngBunka

    Next i

    Application.ScreenUpdating = True

End Sub
Změna barevnosti s pomocí VBA

Změna barevnosti s pomocí VBA

Příloha:
prebarveni.zip

Klikni a stahuj!