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

Як змінити колір фігури на основі значення комірки в Excel?

Змінити колір фігури на основі конкретного значення комірки може бути цікавим завданням у Excel, наприклад, якщо значення комірки в А1 менше 100, колір фігури - червоний, якщо А1 більше 100 і менше 200, колір фігури - жовтий, а коли А1 більше 200, колір фігури - зелений, як показано на наступному знімку екрана. Щоб змінити колір фігури на основі значення клітинки, ця стаття представить метод для вас.

doc змінити колір форми 1

Змінюйте колір фігури на основі значення комірки за допомогою коду VBA


стрілка синя права міхур Змінюйте колір фігури на основі значення комірки за допомогою коду VBA


Нижче наведений код VBA може допомогти вам змінити колір фігури на основі значення клітинки. Будь ласка, виконайте такі дії:

1. Клацніть правою кнопкою миші вкладку аркуша, для якої потрібно змінити колір фігури, а потім виберіть Переглянути код з контекстного меню, що з’явиться Microsoft Visual Basic для додатків вікно, скопіюйте та вставте наступний код у порожнє Модулі вікна.

Код VBA: Зміна кольору фігури на основі значення комірки:

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

doc змінити колір форми 2

2. А потім, коли ви вводите значення в клітинку А1, колір фігури буде змінено відповідно до значення комірки, як ви визначили.

примітки: У наведеному вище коді, A1 - це значення клітинки, на якому буде змінено колір вашої фігури, і Овальний 1 - це назва фігури, яку ви вставили, ви можете змінити їх відповідно до своїх потреб.


Найкращі інструменти для підвищення продуктивності офісу

Kutools для Excel вирішує більшість ваших проблем і збільшує продуктивність на 80%

  • Повторне використання: Швидко вставте складні формули, діаграми і все, що ви використовували раніше; Шифрувати комірки з паролем; Створити список розсилки та надсилати електронні листи ...
  • Супер формула бар (легко редагувати кілька рядків тексту та формули); Макет читання (легко читати та редагувати велику кількість комірок); Вставте у відфільтрований діапазон...
  • Об’єднати клітинки / рядки / стовпці без втрати даних; Вміст розділених комірок; Об'єднати повторювані рядки / стовпці... Запобігання дублюючим клітинам; Порівняйте діапазони...
  • Виберіть Повторюваний або Унікальний Рядки; Виберіть Пусті рядки (усі клітинки порожні); Супер знахідка та нечітка знахідка у багатьох робочих зошитах; Випадковий вибір ...
  • Точна копія Кілька клітинок без зміни посилання на формулу; Автоматичне створення посилань на кілька аркушів; Вставте кулі, Прапорці та інше ...
  • Витяг тексту, Додати текст, Видалити за позицією, Видаліть пробіл; Створення та друк проміжних підсумків підкачки; Перетворення вмісту комірок та коментарів...
  • Супер фільтр (зберегти та застосувати схеми фільтрів до інших аркушів); Розширене сортування за місяцем / тижнем / днем, частотою та іншим; Спеціальний фільтр жирним, курсивом ...
  • Поєднайте робочі зошити та робочі аркуші; Об’єднати таблиці на основі ключових стовпців; Розділіть дані на кілька аркушів; Пакетне перетворення xls, xlsx та PDF...
  • Понад 300 потужних функцій. Підтримує Office / Excel 2007-2019 та 365. Підтримує всі мови. Простота розгортання на вашому підприємстві чи в організації. Повна функція 30-денної безкоштовної пробної версії. 60-денна гарантія повернення грошей.
вкладка kte 201905

Вкладка Office забезпечує інтерфейс з вкладками для Office і значно спрощує вашу роботу

  • Увімкніть редагування та читання на вкладках у Word, Excel, PowerPoint, Publisher, Access, Visio та Project.
  • Відкривайте та створюйте кілька документів на нових вкладках того самого вікна, а не в нових вікнах.
  • Збільшує вашу продуктивність на 50% та зменшує сотні клацань миші для вас щодня!
дно офісної таблиці
Коментарі (18)
Оцінено 4 з 5 · рейтинги 1
Цей коментар був мінімізований модератором на сайті
Як щодо того, якщо у нас є більше 1 об’єкта на аркуші, кольори якого змінюються відповідно до введеного значення, скажімо, в A1, B1, C1....
Цей коментар був мінімізований модератором на сайті
Привіт, Едвард,
Рада допомогти. Скопіюйте та вставте наведений нижче код VBA у порожнє вікно модуля.

Підтестовий макрос2()
Dim dblHt As Double
Dim rngC як діапазон
Dim lngr As Long
Dim dblMargin As Double
Dim lngSR As Long

lngSR = 2 'Рядок, де починаються дані

dblMargin = 6 ' Відстань між фігурами

'При помилці Відновити далі
ActiveSheet.Shapes.SelectAll
Виділення. Видалити
При помилці GoTo 0


dblHt = рядки(lngSR).Висота * 4

Для lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Ячейки(lngSR, "D").Ліва + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Ячейки(lngSR, "D").Вгору + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt - 2 * dblMargin, _
dblHt - 2 * dblMargin).Вибрати
Selection.Name = "Round" & Cells(lngr, "A").Address
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.Відступ першого рядка = 0
.Вирівнювання = msoAlignCenter
Кінець з
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Жирний = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Розмір = 12
Кінець з
З Selection.ShapeRange.Fill
.Visible = msoTrue
Якщо клітинки(lngr, "A").Значення > 70 Тоді
.ForeColor.RGB = RGB(0, 176, 80)
ElseIf Cells(lngr, "A").Значення >= 40 Тоді
.ForeColor.RGB = RGB(255, 255, 70)
Ще
.ForeColor.RGB = RGB(255, 0, 0)
End If
.Прозорість = 0
.Твердий
Кінець з
Наступний lngr
Діапазон ("A1"). Виберіть
End Sub

Після того, як ви запустите код VBA, наведений вище, ви побачите, що створено кілька фігур, а кольори цих фігур змінюються відповідно до VBA.
Будь ласка, подивіться мій скріншот. Сподіваюся, це може допомогти. Гарного дня.
З повагою,
Менді
Цей коментар був мінімізований модератором на сайті
У мене є 300 фігур на аркуші. Чи можна перевірити значення суміжної або зв’язаної комірки (порожня чи непорожня) на аркуші та розфарбувати пов’язані фігури за допомогою коду VBA?
Цей коментар був мінімізований модератором на сайті
Чудове рішення vba.

Також можна використовувати умовне форматування для фарбування фігур.

Встановіть назву кожної фігури як значення комірки. Використовуючи With Each Shape, встановіть колір фігури як колір клітинки для всіх іменованих фігур.

Колір комірки можна змінити за допомогою умовного форматування на основі числових значень.

Наприклад, колір напівпрозорого перекриття на карті міста можна використовувати для графічного відображення щільності населення на квартал із градуйованою колірною схемою.
Цей коментар був мінімізований модератором на сайті
Чи можете ви поділитися прикладом коду?
Цей коментар був мінімізований модератором на сайті
Як це можна застосувати, якщо у вас є кілька фігур на одному аркуші?
Цей коментар був мінімізований модератором на сайті
Привіт, Ясир,
Рада допомогти. Скопіюйте та вставте наведений нижче код VBA у порожнє вікно модуля.

Підтестовий макрос2()
Dim dblHt As Double
Dim rngC як діапазон
Dim lngr As Long
Dim dblMargin As Double
Dim lngSR As Long

lngSR = 2 'Рядок, де починаються дані

dblMargin = 6 ' Відстань між фігурами

'При помилці Відновити далі
ActiveSheet.Shapes.SelectAll
Виділення. Видалити
При помилці GoTo 0


dblHt = рядки(lngSR).Висота * 4

Для lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Ячейки(lngSR, "D").Ліва + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Ячейки(lngSR, "D").Вгору + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt - 2 * dblMargin, _
dblHt - 2 * dblMargin).Вибрати
Selection.Name = "Round" & Cells(lngr, "A").Address
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.Відступ першого рядка = 0
.Вирівнювання = msoAlignCenter
Кінець з
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Жирний = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Розмір = 12
Кінець з
З Selection.ShapeRange.Fill
.Visible = msoTrue
Якщо клітинки(lngr, "A").Значення > 70 Тоді
.ForeColor.RGB = RGB(0, 176, 80)
ElseIf Cells(lngr, "A").Значення >= 40 Тоді
.ForeColor.RGB = RGB(255, 255, 70)
Ще
.ForeColor.RGB = RGB(255, 0, 0)
End If
.Прозорість = 0
.Твердий
Кінець з
Наступний lngr
Діапазон ("A1"). Виберіть
End Sub

Після того, як ви запустите код VBA, наведений вище, ви побачите, що створено кілька фігур, а кольори цих фігур змінюються відповідно до VBA.
Будь ласка, подивіться мій скріншот. Сподіваюся, це може допомогти. Гарного дня.
З повагою,
Менді
Цей коментар був мінімізований модератором на сайті
Дякую за це, що дійсно корисно.

Тепер я хочу використовувати його зі зведеною таблицею на іншому робочому аркуші, яка керує даними на аркуші з фігурами, колір яких я хочу змінити. Однак, коли я зміню вибір у зведеній таблиці, дані на аркуші з фігурами оновлюються, але код не запускається, тому фігури не змінюють колір

Якщо я вручну зміню значення, код запускається, а колір фігур оновлюється.

Запитання: що мені потрібно додати до коду вище, щоб дозволити його запуск автоматично?
Цей коментар був мінімізований модератором на сайті
Як змусити приватний суб’єкт читати результат обчислення AVERAGE(C1,C5,C9)?

Sub працює лише з числовими значеннями; будь-які думки та пропозиції дуже цінуються.
Цей коментар був мінімізований модератором на сайті
Привіт, Чезаре, як справи? Я помічаю, що код VBA може працювати з розрахунком AVERAGE(число, число...). Але хитрість полягає в тому, що щоразу, коли ви змінюєте значення в обчисленні, вам потрібно двічі клацнути формулу в клітинці, щоб знову запрацювати VBA. 
Наприклад, у комірці A1, після того як ми введемо формулу =СРЕДНЄ(C2:D3), VBA працює і відповідно змінює колір фігури. Будь ласка, дивіться знімок екрана 1. C0.2:D2, результат, повернутий у клітинку A3, змінюється, але колір фігури ще не змінено. У цьому випадку нам потрібно двічі клацнути формулу в клітинці A1, щоб запустити VBA. Тоді колір фігури буде відповідно змінений. Будь ласка, дивіться скріншоти 1 і 2.
Цей коментар був мінімізований модератором на сайті
Привіт... чудове рішення... але як застосувати його до кількох фігур на основі відповідних значень діапазону клітинок. Наперед дуже дякую за допомогу.
Цей коментар був мінімізований модератором на сайті
Привіт Райане,
Рада допомогти. Скопіюйте та вставте наведений нижче код VBA у порожнє вікно модуля.

Підтестовий макрос2()
Dim dblHt As Double
Dim rngC як діапазон
Dim lngr As Long
Dim dblMargin As Double
Dim lngSR As Long

lngSR = 2 'Рядок, де починаються дані

dblMargin = 6 ' Відстань між фігурами

'При помилці Відновити далі
ActiveSheet.Shapes.SelectAll
Виділення. Видалити
При помилці GoTo 0


dblHt = рядки(lngSR).Висота * 4

Для lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Ячейки(lngSR, "D").Ліва + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Ячейки(lngSR, "D").Вгору + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt - 2 * dblMargin, _
dblHt - 2 * dblMargin).Вибрати
Selection.Name = "Round" & Cells(lngr, "A").Address
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.Відступ першого рядка = 0
.Вирівнювання = msoAlignCenter
Кінець з
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Жирний = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Розмір = 12
Кінець з
З Selection.ShapeRange.Fill
.Visible = msoTrue
Якщо клітинки(lngr, "A").Значення > 70 Тоді
.ForeColor.RGB = RGB(0, 176, 80)
ElseIf Cells(lngr, "A").Значення >= 40 Тоді
.ForeColor.RGB = RGB(255, 255, 70)
Ще
.ForeColor.RGB = RGB(255, 0, 0)
End If
.Прозорість = 0
.Твердий
Кінець з
Наступний lngr
Діапазон ("A1"). Виберіть
End Sub

Після того, як ви запустите код VBA, наведений вище, ви побачите, що створено кілька фігур, а кольори цих фігур змінюються відповідно до VBA.
Будь ласка, подивіться мій скріншот. Сподіваюся, це може допомогти. Гарного дня.
З повагою,
Менді
Цей коментар був мінімізований модератором на сайті
¿Cómo hacemos si tenemos más de 1 Oval en la hoja de trabajo cuyos colores cambian de acuerdo con el valor ingresado, por ejemplo, en A1, B1, C1...? Mil gracias por su ayuda!

Цей коментар був мінімізований модератором на сайті
Привіт, Марія Ноель!
Рада допомогти. Скопіюйте та вставте наведений нижче код VBA у порожнє вікно модуля.

Підтестовий макрос2()
Dim dblHt As Double
Dim rngC як діапазон
Dim lngr As Long
Dim dblMargin As Double
Dim lngSR As Long

lngSR = 2 'Рядок, де починаються дані

dblMargin = 6 ' Відстань між фігурами

'При помилці Відновити далі
ActiveSheet.Shapes.SelectAll
Виділення. Видалити
При помилці GoTo 0


dblHt = рядки(lngSR).Висота * 4

Для lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Ячейки(lngSR, "D").Ліва + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Ячейки(lngSR, "D").Вгору + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt - 2 * dblMargin, _
dblHt - 2 * dblMargin).Вибрати
Selection.Name = "Round" & Cells(lngr, "A").Address
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.Відступ першого рядка = 0
.Вирівнювання = msoAlignCenter
Кінець з
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Жирний = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Розмір = 12
Кінець з
З Selection.ShapeRange.Fill
.Visible = msoTrue
Якщо клітинки(lngr, "A").Значення > 70 Тоді
.ForeColor.RGB = RGB(0, 176, 80)
ElseIf Cells(lngr, "A").Значення >= 40 Тоді
.ForeColor.RGB = RGB(255, 255, 70)
Ще
.ForeColor.RGB = RGB(255, 0, 0)
End If
.Прозорість = 0
.Твердий
Кінець з
Наступний lngr
Діапазон ("A1"). Виберіть
End Sub

Після того, як ви запустите код VBA, наведений вище, ви побачите, що створено кілька фігур, а кольори цих фігур змінюються відповідно до VBA.
Будь ласка, подивіться мій скріншот. Сподіваюся, це може допомогти. Гарного дня.
З повагою,
Менді
Цей коментар був мінімізований модератором на сайті
Чудове рішення! Як я можу зробити, якщо на аркуші є більше 1 овалу, кольори якого змінюються відповідно до введеного значення, скажімо, в A1, B1, C1? Наперед дякую за відповідь! 
Цей коментар був мінімізований модератором на сайті
Привіт, mnsosa, радий допомогти. Скопіюйте та вставте наведений нижче код VBA у порожнє вікно модуля.
Підтестовий макрос2()
Dim dblHt As Double
Dim rngC як діапазон
Dim lngr As Long
Dim dblMargin As Double
Dim lngSR As Long

lngSR = 2 'Рядок, де починаються дані

dblMargin = 6 ' Відстань між фігурами

'При помилці Відновити далі
ActiveSheet.Shapes.SelectAll
Виділення. Видалити
При помилці GoTo 0


dblHt = рядки(lngSR).Висота * 4

Для lngr = lngSR To Cells(lngSR, "A").End(xlDown).Row
ActiveSheet.Shapes.AddShape(msoShapeOval, _
Ячейки(lngSR, "D").Ліва + ((lngr - lngSR) Mod 4) * dblHt + dblMargin, _
Ячейки(lngSR, "D").Вгору + Int((lngr - lngSR) / 4) * dblHt + dblMargin, _
dblHt - 2 * dblMargin, _
dblHt - 2 * dblMargin).Вибрати
Selection.Name = "Round" & Cells(lngr, "A").Address
Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Cells(lngr, "A").Value
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).ParagraphFormat
.Відступ першого рядка = 0
.Вирівнювання = msoAlignCenter
Кінець з
З Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 2).Font
.Жирний = msoTrue
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Розмір = 12
Кінець з
З Selection.ShapeRange.Fill
.Visible = msoTrue
Якщо клітинки(lngr, "A").Значення > 70 Тоді
.ForeColor.RGB = RGB(0, 176, 80)
ElseIf Cells(lngr, "A").Значення >= 40 Тоді
.ForeColor.RGB = RGB(255, 255, 70)
Ще
.ForeColor.RGB = RGB(255, 0, 0)
End If
.Прозорість = 0
.Твердий
Кінець з
Наступний lngr
Діапазон ("A1"). Виберіть
End Sub

Після того, як ви запустите код VBA, наведений вище, ви побачите, що створено кілька фігур, а кольори цих фігур змінюються відповідно до VBA. Будь ласка, перегляньте мій знімок екрана. Сподіваюся, це може допомогти. Гарного дня. З повагою, Менді
Цей коментар був мінімізований модератором на сайті
Я новачок у VBA і борюся з чимось. Мені потрібно, щоб 9 різних клітинок A1-A9 змінили колір 9 різних об’єктів. Предметами є кубики 1-9. Щоб уточнити, кожна клітинка має змінити лише один об’єкт A1-Cube 1 тощо. Червоний, якщо він не відповідає значенню, і зелений, якщо він перевищує значення. Значення "пройшов/не пройшов" може змінитися, тому замість того, щоб мати значення у VBA, мені потрібно, щоб воно посилалося на клітинку A10, яка має значення "пройшов/не пройшов". Будь-який шанс, хтось міг би написати зразок коду, з яким я можу працювати.

Дякую
Цей коментар був мінімізований модератором на сайті
Привіт, відмінно приклад.
Pero como seria 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
Оцінено 4 з 5
There are no comments posted here yet
Залишайте свої коментарі
Публікація як гість
×
Оцініть цю публікацію:
0   Персонажі
Рекомендовані місця