Окрас фигур по значению в ячейке

@АЛКС · Регистрация: 17.02.2016

Author24 — интернет-сервис помощи студентам

Добрый день, подскажите пожалуйста как окрасить фигуры в экселе по значению в ячейке, т.е. в примере на листе1 есть 4 фигуры созданные в экселе, надо чтоб каждая фигура окрашивалась по значению в ячейке на листе2 (Название столбца "окрас по значению в ячейке") согласно легенде, файл прилогаю

Наименование фигуры	окрас по значению в ячейке	легенда
Полилиния 2	1	1 = желтое
Полилиния 5	2	2 = красное
Полилиния 6	1	3 = розовое
Полилиния 7	3	4 = белое

@АЛКС · 29.11.2016, 22:02 **[ТС]**

всем спасибо, написал сам, но было бы интересно посмотреть другой код м.б. он лучше чем мой реализовал через таргет, по цвету соседней ячейки в легенде, проще говоря если 1 то цвет берется из легенды (предварительно залив ячейки нужным цветом)

@Казанский · 29.11.2016, 22:49

АЛКС,

Visual Basic

Sub Alks()
Dim cols(), c As Range
  cols = Array(, vbYellow, vbRed, &HCBC0FF, vbWhite)
  For Each c In Sheets("Лист2").Range("B7", Sheets("Лист2").Cells(Rows.Count, "B").End(xlUp))
    Sheets("Лист1").Shapes(c.Value).Fill.ForeColor.RGB = cols(c.Offset(, 1))
  Next
End Sub

@АЛКС · 30.11.2016, 20:28 **[ТС]**

Казанский, отличный у Вас код, подскажите пожалуйста как можно оптимизировать мой код (фигур очень много для закраски) по пытался переделать на Ваш, не получилось, у Вас он отличный но цвета заранее фиксированные в коде, а мне бы чтоб цвета из ячейки можно было брать или если можно лучше Ваш код чуть чуть дополните цветами из ячеек

вот мой громоздкий код

Visual Basic

Private Sub Worksheet_Change(ByVal Target As Range)
Dim x1 As Shape, x2 As Shape
Set x1 = Sheets("Лист2").Shapes("название фигуры1")
Set x2 = Sheets("Лист2").Shapes("название фигуры2")
Set x3 = Sheets("Лист2").Shapes("название фигуры3")
Set x3 = Sheets("Лист2").Shapes("название фигуры4")
 
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("c7")) Is Nothing Then
        Select Case Target.Value
            Case 1
                x1.Fill.ForeColor.RGB = Range("j2").Interior.Color
            Case 2
                x1.Fill.ForeColor.RGB = Range("j3").Interior.Color
            Case 3
                x1.Fill.ForeColor.RGB = Range("j4").Interior.Color
            Case 4
                x1.Fill.ForeColor.RGB = Range("j5").Interior.Color
            Case 5
                x1.Fill.ForeColor.RGB = Range("j6").Interior.Color
            Case 10
                x1.Fill.ForeColor.RGB = Range("j7").Interior.Color
        End Select
    End If
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("c8")) Is Nothing Then
        Select Case Target.Value
            Case 1
                x2.Fill.ForeColor.RGB = Range("j2").Interior.Color
            Case 2
                x2.Fill.ForeColor.RGB = Range("j3").Interior.Color
            Case 3
                x2.Fill.ForeColor.RGB = Range("j4").Interior.Color
            Case 4
                x2.Fill.ForeColor.RGB = Range("j5").Interior.Color
            Case 5
                x2.Fill.ForeColor.RGB = Range("j6").Interior.Color
            Case 10
                x2.Fill.ForeColor.RGB = Range("j7").Interior.Color
        End Select
    End If
    If Not Intersect(Target, Range("c9")) Is Nothing Then
        Select Case Target.Value
            Case 1
                x3.Fill.ForeColor.RGB = Range("j2").Interior.Color
            Case 2
                x3.Fill.ForeColor.RGB = Range("j3").Interior.Color
            Case 3
                x3.Fill.ForeColor.RGB = Range("j4").Interior.Color
            Case 4
                x3.Fill.ForeColor.RGB = Range("j5").Interior.Color
            Case 5
                x3.Fill.ForeColor.RGB = Range("j6").Interior.Color
            Case 10
                x3.Fill.ForeColor.RGB = Range("j7").Interior.Color
        End Select
    End If
    
End Sub

Добавлено через 17 минут
чуточку опечатался последний не x3 a x4

@Казанский · 04.12.2016, 19:53

АЛКС, нет файла, соответствующего коду. Приспособил файл из первого поста, вот что получилось.
Можно менять сразу несколько ячеек из диапазона C7:C10 (автозаполнение, вставка).

Visual Basic

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
  On Error Resume Next
  For Each c In Intersect(Target, Range("C7:C10"))
    Select Case c.Value
    Case 1 To 5
      Sheets("Лист2").Shapes(c.Offset(, -1).Value).Fill.ForeColor.RGB = Range("j1").Offset(c.Value).Interior.Color
    Case 10
      Sheets("Лист2").Shapes(c.Offset(, -1).Value).Fill.ForeColor.RGB = Range("j7").Interior.Color
    End Select
  Next
End Sub

@Devil Byte · 23.04.2021, 09:09

Казанский,
Добрый день, скажите как приспособить ваш макрос под такой вариант, перечислены номера комнат. У каждой из комнат может быть один из статусов - сдана, не сдана, готовится к сдаче. Как применять к фигурам имена, а вместо цифр прописывать статус?

Окрас фигур по значению в ячейке

Решение

Решение

@АЛКС 5 / 3 / 2 Регистрация: 17.02.2016 Сообщений: 344
	29.11.2016, 22:02 [ТС]	2
	всем спасибо, написал сам, но было бы интересно посмотреть другой код м.б. он лучше чем мой реализовал через таргет, по цвету соседней ячейки в легенде, проще говоря если 1 то цвет берется из легенды (предварительно залив ячейки нужным цветом) 0

@Devil Byte 0 / 0 / 0 Регистрация: 07.03.2019 Сообщений: 11
	23.04.2021, 09:09	6
	Казанский, Добрый день, скажите как приспособить ваш макрос под такой вариант, перечислены номера комнат. У каждой из комнат может быть один из статусов - сдана, не сдана, готовится к сдаче. Как применять к фигурам имена, а вместо цифр прописывать статус? 0