Note: The other languages of the website are Google-translated. Back to English

Jak změnit barvu tvaru na základě hodnoty buňky v aplikaci Excel?

Změna barvy tvaru na základě konkrétní hodnoty buňky může být zajímavým úkolem v aplikaci Excel, například pokud je hodnota buňky v A1 menší než 100, barva tvaru je červená, pokud je A1 větší než 100 a menší než 200, barva tvaru je žlutá, a když je A1 větší než 200, barva tvaru je zelená, jak ukazuje následující snímek obrazovky. Chcete-li změnit barvu tvaru na základě hodnoty buňky, tento článek vám představí metodu.

barva dokumentu změnit tvar 1

Změňte barvu tvaru na základě hodnoty buňky pomocí kódu VBA


šipka modrá pravá bublina Změňte barvu tvaru na základě hodnoty buňky pomocí kódu VBA


Níže uvedený kód VBA vám pomůže změnit barvu tvaru na základě hodnoty buňky, postupujte takto:

1. Klikněte pravým tlačítkem na kartu listu, kterou chcete změnit barvu tvaru, a poté vyberte Zobrazit kód z kontextové nabídky ve vyskakovacím okně Microsoft Visual Basic pro aplikace zkopírujte a vložte následující kód do mezery Modul okno.

Kód VBA: Změna barvy tvaru na základě hodnoty buňky:

Private Sub Worksheet_Change(ByVal Target As Range)
'Updateby Extendoffice 20160704
    If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) Then
        If Target.Value < 100 Then
            ActiveSheet.Shapes("Oval 1").Fill.ForeColor.RGB = vbRed
        ElseIf Target.Value >= 100 And Target.Value < 200 Then
            ActiveSheet.Shapes("Oval 1").Fill.ForeColor.RGB = vbYellow
        Else
            ActiveSheet.Shapes("Oval 1").Fill.ForeColor.RGB = vbGreen
        End If
    End If
End Sub

barva dokumentu změnit tvar 2

2. A poté, když zadáte hodnotu do buňky A1, barva tvaru se změní s hodnotou buňky, jak jste definovali.

Poznámka: Ve výše uvedeném kódu, A1 je hodnota buňky, na které by byla změněna barva tvaru, a Oválné 1 je název tvaru vloženého tvaru, můžete je podle potřeby změnit.


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2019 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Kompletní funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50% a omezuje stovky kliknutí myší každý den!
officetab dno
Komentáře (18)
Hodnocení 4 z 5 · 1 hodnocení:
Tento komentář byl moderátorem webu minimalizován
Co takhle, když máme v listu více než 1 objekt, jehož barvy se mění podle zadání hodnoty řekněme v A1, B1, C1....
Tento komentář byl moderátorem webu minimalizován
Ahoj Edwarde,
Rád jsem pomohl. Zkopírujte a vložte níže uvedený kód VBA do prázdného okna modulu.

Sub TestMacro2()
Dim dblHt As Double
Dim rngC As Range
Dim lngr As Long
Ztlumit dblMargin jako dvojitý
Dim lngSR As Long

lngSR = 2 'Řádek, kde začínají data

dblMargin = 6 ' Vzdálenost mezi tvary

'Při chybě pokračovat dále
ActiveSheet.Shapes.SelectAll
Výběr. Odstranit
Při chybě GoTo 0


dblHt = Řádky(lngSR).Výška * 4

For lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Cells(lngSR, "D").Left + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Cells(lngSR, "D").Top + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt – 2 * dblMargin, _
dblHt - 2 * dblMargin).Vyberte
Selection.Name = "Round" & Cells(lngr, "A").Adresa
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
Konec s
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Tučné = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Naplňte.Pevné
.Velikost = 12
Konec s
S Selection.ShapeRange.Fill
.Visible = msoTrue
If Cells(lngr, "A").Hodnota > 70 Pak
.ForeColor.RGB = RGB(0; 176; 80)
ElseIf Cells(lngr, "A").Hodnota >= 40 Potom
.ForeColor.RGB = RGB(255; 255; 70)
Jiný
.ForeColor.RGB = RGB(255; 0; 0)
End If
.Transparentnost = 0
.Pevný
Konec s
Další lngr
Rozsah("A1").Vyberte
End Sub

Po spuštění výše uvedeného kódu VBA uvidíte, že se vygeneruje více obrazců a barvy těchto obrazců se změní podle VBA.
Podívejte se prosím na můj snímek obrazovky. Doufám, že to může pomoci. Hezký den.
S pozdravem,
Mandy
Tento komentář byl moderátorem webu minimalizován
V listu mám 300 tvarů. Je možné zkontrolovat hodnotu sousední nebo propojené buňky (prázdné nebo neprázdné) v listu a obarvit propojené tvary pomocí kódu VBA?
Tento komentář byl moderátorem webu minimalizován
Skvělé řešení vba.

Pro obarvení tvarů je možné použít i podmíněné formátování.

Nastavte název každého tvaru jako hodnotu buňky. Pomocí možnosti S každým tvarem pak nastavte barvu tvaru jako barvu buňky pro všechny pojmenované tvary.

Barvu buňky lze změnit pomocí podmíněného formátování na základě číselných hodnot.

Například barvu poloprůhledného překrytí na mapě města lze použít ke grafickému označení hustoty obyvatelstva na blok s odstupňovaným barevným schématem.
Tento komentář byl moderátorem webu minimalizován
Můžete se podělit o příklad kódu?
Tento komentář byl moderátorem webu minimalizován
Jak to lze použít, pokud máte ve stejném listu více tvarů?
Tento komentář byl moderátorem webu minimalizován
Ahoj Yasire,
Rád jsem pomohl. Zkopírujte a vložte níže uvedený kód VBA do prázdného okna modulu.

Sub TestMacro2()
Dim dblHt As Double
Dim rngC As Range
Dim lngr As Long
Ztlumit dblMargin jako dvojitý
Dim lngSR As Long

lngSR = 2 'Řádek, kde začínají data

dblMargin = 6 ' Vzdálenost mezi tvary

'Při chybě pokračovat dále
ActiveSheet.Shapes.SelectAll
Výběr. Odstranit
Při chybě GoTo 0


dblHt = Řádky(lngSR).Výška * 4

For lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Cells(lngSR, "D").Left + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Cells(lngSR, "D").Top + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt – 2 * dblMargin, _
dblHt - 2 * dblMargin).Vyberte
Selection.Name = "Round" & Cells(lngr, "A").Adresa
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
Konec s
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Tučné = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Naplňte.Pevné
.Velikost = 12
Konec s
S Selection.ShapeRange.Fill
.Visible = msoTrue
If Cells(lngr, "A").Hodnota > 70 Pak
.ForeColor.RGB = RGB(0; 176; 80)
ElseIf Cells(lngr, "A").Hodnota >= 40 Potom
.ForeColor.RGB = RGB(255; 255; 70)
Jiný
.ForeColor.RGB = RGB(255; 0; 0)
End If
.Transparentnost = 0
.Pevný
Konec s
Další lngr
Rozsah("A1").Vyberte
End Sub

Po spuštění výše uvedeného kódu VBA uvidíte, že se vygeneruje více obrazců a barvy těchto obrazců se změní podle VBA.
Podívejte se prosím na můj snímek obrazovky. Doufám, že to může pomoci. Hezký den.
S pozdravem,
Mandy
Tento komentář byl moderátorem webu minimalizován
Díky za to, což je opravdu užitečné.

Nyní ji chci použít s kontingenční tabulkou na jiném listu, který řídí data na listu s tvary, u kterých chci změnit barvu. Když však změním výběr v kontingenční tabulce, data na listu s tvary se aktualizují, ale kód se nespustí, takže tvary nezmění barvu

Pokud ručně změním hodnoty, kód se spustí a barva tvarů se aktualizuje.

Otázka: Co musím přidat do výše uvedeného kódu, aby se automaticky spouštěl?
Tento komentář byl moderátorem webu minimalizován
Jak zařídím, aby soukromá ponorka četla výsledek z výpočtu PRŮMĚR (C1,C5,C9)?

Sub pracuje pouze s číselnými hodnotami; jakékoli myšlenky a návrhy jsou velmi ceněny.
Tento komentář byl moderátorem webu minimalizován
Ahoj Cesare, jak se máš? Všiml jsem si, že kód VBA umí pracovat s výpočtem AVERAGE(číslo, číslo...). Trik je ale v tom, že pokaždé, když změníte hodnoty ve výpočtu, musíte dvakrát kliknout na vzorec v buňce, aby VBA znovu fungovalo. 
Například v buňce A1 poté, co zadáme vzorec = AVERAGE(C2:D3), VBA funguje a podle toho změní barvu tvaru. Viz snímek obrazovky 1. C0.2:D2, vrácený výsledek v buňce A3 se změní, ale barva tvaru se ještě nezměnila. V tomto případě musíme dvakrát kliknout na vzorec v buňce A1, aby VBA fungoval. Poté se barva tvaru odpovídajícím způsobem změní. Podívejte se na snímky obrazovky 1 a 2.
Tento komentář byl moderátorem webu minimalizován
Ahoj... výborné řešení... ale jak to mám aplikovat na více tvarů na základě odpovídajících hodnot řady buněk. Předem mnohokrát děkuji za pomoc.
Tento komentář byl moderátorem webu minimalizován
Ahoj Ryane,
Rád jsem pomohl. Zkopírujte a vložte níže uvedený kód VBA do prázdného okna modulu.

Sub TestMacro2()
Dim dblHt As Double
Dim rngC As Range
Dim lngr As Long
Ztlumit dblMargin jako dvojitý
Dim lngSR As Long

lngSR = 2 'Řádek, kde začínají data

dblMargin = 6 ' Vzdálenost mezi tvary

'Při chybě pokračovat dále
ActiveSheet.Shapes.SelectAll
Výběr. Odstranit
Při chybě GoTo 0


dblHt = Řádky(lngSR).Výška * 4

For lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Cells(lngSR, "D").Left + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Cells(lngSR, "D").Top + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt – 2 * dblMargin, _
dblHt - 2 * dblMargin).Vyberte
Selection.Name = "Round" & Cells(lngr, "A").Adresa
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
Konec s
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Tučné = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Naplňte.Pevné
.Velikost = 12
Konec s
S Selection.ShapeRange.Fill
.Visible = msoTrue
If Cells(lngr, "A").Hodnota > 70 Pak
.ForeColor.RGB = RGB(0; 176; 80)
ElseIf Cells(lngr, "A").Hodnota >= 40 Potom
.ForeColor.RGB = RGB(255; 255; 70)
Jiný
.ForeColor.RGB = RGB(255; 0; 0)
End If
.Transparentnost = 0
.Pevný
Konec s
Další lngr
Rozsah("A1").Vyberte
End Sub

Po spuštění výše uvedeného kódu VBA uvidíte, že se vygeneruje více obrazců a barvy těchto obrazců se změní podle VBA.
Podívejte se prosím na můj snímek obrazovky. Doufám, že to může pomoci. Hezký den.
S pozdravem,
Mandy
Tento komentář byl moderátorem webu minimalizován
¿Cómo hacemos si tenemos více de 1 Oval en la hoja de trabajo cuyos colores cambian de acuerdo con el valor ingresado, or ejemplo, en A1, B1, C1...? Mil gracias por su ayuda!

Tento komentář byl moderátorem webu minimalizován
Ahoj Marío Noel,
Rád jsem pomohl. Zkopírujte a vložte níže uvedený kód VBA do prázdného okna modulu.

Sub TestMacro2()
Dim dblHt As Double
Dim rngC As Range
Dim lngr As Long
Ztlumit dblMargin jako dvojitý
Dim lngSR As Long

lngSR = 2 'Řádek, kde začínají data

dblMargin = 6 ' Vzdálenost mezi tvary

'Při chybě pokračovat dále
ActiveSheet.Shapes.SelectAll
Výběr. Odstranit
Při chybě GoTo 0


dblHt = Řádky(lngSR).Výška * 4

For lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Cells(lngSR, "D").Left + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Cells(lngSR, "D").Top + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt – 2 * dblMargin, _
dblHt - 2 * dblMargin).Vyberte
Selection.Name = "Round" & Cells(lngr, "A").Adresa
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
Konec s
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Tučné = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Naplňte.Pevné
.Velikost = 12
Konec s
S Selection.ShapeRange.Fill
.Visible = msoTrue
If Cells(lngr, "A").Hodnota > 70 Pak
.ForeColor.RGB = RGB(0; 176; 80)
ElseIf Cells(lngr, "A").Hodnota >= 40 Potom
.ForeColor.RGB = RGB(255; 255; 70)
Jiný
.ForeColor.RGB = RGB(255; 0; 0)
End If
.Transparentnost = 0
.Pevný
Konec s
Další lngr
Rozsah("A1").Vyberte
End Sub

Po spuštění výše uvedeného kódu VBA uvidíte, že se vygeneruje více obrazců a barvy těchto obrazců se změní podle VBA.
Podívejte se prosím na můj snímek obrazovky. Doufám, že to může pomoci. Hezký den.
S pozdravem,
Mandy
Tento komentář byl moderátorem webu minimalizován
Skvělé řešení! Jak mohu udělat, když mám v listu více než 1 ovál, jehož barvy se mění podle zadání hodnoty, řekněme v A1, B1, C1? Díky předem za Vaši odpověď! 
Tento komentář byl moderátorem webu minimalizován
Ahoj mnsosa, jsem rád, že mohu pomoci. Zkopírujte a vložte níže uvedený kód VBA do prázdného okna modulu.
Sub TestMacro2()
Dim dblHt As Double
Dim rngC As Range
Dim lngr As Long
Ztlumit dblMargin jako dvojitý
Dim lngSR As Long

lngSR = 2 'Řádek, kde začínají data

dblMargin = 6 ' Vzdálenost mezi tvary

'Při chybě pokračovat dále
ActiveSheet.Shapes.SelectAll
Výběr. Odstranit
Při chybě GoTo 0


dblHt = Řádky(lngSR).Výška * 4

For lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Cells(lngSR, "D").Left + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Cells(lngSR, "D").Top + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt – 2 * dblMargin, _
dblHt - 2 * dblMargin).Vyberte
Selection.Name = "Round" & Cells(lngr, "A").Adresa
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
Konec s
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Tučné = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Naplňte.Pevné
.Velikost = 12
Konec s
S Selection.ShapeRange.Fill
.Visible = msoTrue
If Cells(lngr, "A").Hodnota > 70 Pak
.ForeColor.RGB = RGB(0; 176; 80)
ElseIf Cells(lngr, "A").Hodnota >= 40 Potom
.ForeColor.RGB = RGB(255; 255; 70)
Jiný
.ForeColor.RGB = RGB(255; 0; 0)
End If
.Transparentnost = 0
.Pevný
Konec s
Další lngr
Rozsah("A1").Vyberte
End Sub

Po spuštění kódu VBA výše uvidíte, že se vygeneruje několik tvarů a barvy těchto tvarů se změní podle VBA. Podívejte se prosím na můj snímek obrazovky. Doufám, že to může pomoci. Přeji hezký den. S pozdravem Mandy
Tento komentář byl moderátorem webu minimalizován
Jsem ve VBA nový a s něčím bojuji. Potřebuji, aby 9 různých buněk A1-A9 změnilo barvu 9 různých objektů. Předměty jsou kostky 1-9. Jen pro upřesnění, každá buňka má změnit pouze jeden objekt A1-Cube 1 atd. Červená, pokud nesplní hodnotu a zelená, pokud hodnotu překročí. Hodnota pass/fail se může změnit, takže místo toho, abych měl hodnotu ve VBA, potřebuji, aby odkazovala na buňku A10, která má hodnotu pass/fail. Nějaká šance, že by mi někdo mohl projít ukázkový kód, se kterým bych mohl pracovat.

Díky
Tento komentář byl moderátorem webu minimalizován
Ahoj, excelente ejemplo.
Vzhledem k tomu, že se jedná o serii si tengo una forma y quiero ir coloreado poco a poco dependiendo del valor ejemplo:
Si el valor es 50%
Seia mitad roja y mitad verde
Pero que se vaya llenando según el porcentaje vaya aumentando
Hodnocení 4 z 5
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění