столкнулся с такой проблемой. Есть выпадающий список со значениями от 0 до 40 и рядом самодельный график по значениям в ячейке B.
Подскажите если у меня в планах сделать 10 выпадающих списков и 10 графиков, как грамотно оптимизировать код что бы каждый раз не прописывать новые значения переменных?
Это вообще реально?
Добрый вечер, форумчане,
столкнулся с такой проблемой. Есть выпадающий список со значениями от 0 до 40 и рядом самодельный график по значениям в ячейке B.
Подскажите если у меня в планах сделать 10 выпадающих списков и 10 графиков, как грамотно оптимизировать код что бы каждый раз не прописывать новые значения переменных?
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer n = 3 ' количесство кружков ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row)) flg = -1 * (i * 10 <= Target.Value) o(Target.Row)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i End Sub
[/vba] Но вообще первую часть инициализации:
[vba]
Код
For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i
[/vba]
если файл не редактируется (не меняется кол-во кружков), можно было бы засунуть в событие открытия книги... чтобы не каждый раз по новой ссылки назначать.
Gopronotmore, например так: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer n = 3 ' количесство кружков ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row)) flg = -1 * (i * 10 <= Target.Value) o(Target.Row)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i End Sub
[/vba] Но вообще первую часть инициализации:
[vba]
Код
For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i
[/vba]
если файл не редактируется (не меняется кол-во кружков), можно было бы засунуть в событие открытия книги... чтобы не каждый раз по новой ссылки назначать.Roman777
Спасибо большое! Это реально круто! Кружки будут меняться в количестве, по этому в принципе одну вводную и названия изменить не проблема.
Подскажите, а если в выпадающем списке будет текст, например Не выполнено;Выполнено 25%;Выполнено 50%;Выполнено 75%;Выполнено 100%;
я так понимаю что в этом цикле нужно будет менять вводные. Просто я попробовал изменить названия в выпадающем списке и круг сразу покрасился в зеленый [vba]
Код
For i = 1 To UBound(o(Target.Row)) flg = -1 * (i * 10 <= Target.Value) o(Target.Row)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i
[/vba]
Я так полагаю что тип переменный flg перейдет в Sting, шаг флага сменил на 25, но вот как Выполнено и % туда поставить не получается разобраться в виду своего дилетантства.
[vba]
Код
flg = -1 * (i * 25 & "%" <= Target.Value)
[/vba]
Не работает
Можете подсказать как это сделать? А еще бы был очень признателен, если бы Вы подсказали, в Вашем коде где идет ссылка на ячейки, из которых выбирать данные. Например: если я перемещу столбец А:А в столбец D:D код будет работать, и мне непонятно как код ссылается и определяет откуда берутся данные.
Roman777,
Спасибо большое! Это реально круто! Кружки будут меняться в количестве, по этому в принципе одну вводную и названия изменить не проблема.
Подскажите, а если в выпадающем списке будет текст, например Не выполнено;Выполнено 25%;Выполнено 50%;Выполнено 75%;Выполнено 100%;
я так понимаю что в этом цикле нужно будет менять вводные. Просто я попробовал изменить названия в выпадающем списке и круг сразу покрасился в зеленый [vba]
Код
For i = 1 To UBound(o(Target.Row)) flg = -1 * (i * 10 <= Target.Value) o(Target.Row)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i
[/vba]
Я так полагаю что тип переменный flg перейдет в Sting, шаг флага сменил на 25, но вот как Выполнено и % туда поставить не получается разобраться в виду своего дилетантства.
[vba]
Код
flg = -1 * (i * 25 & "%" <= Target.Value)
[/vba]
Не работает
Можете подсказать как это сделать? А еще бы был очень признателен, если бы Вы подсказали, в Вашем коде где идет ссылка на ячейки, из которых выбирать данные. Например: если я перемещу столбец А:А в столбец D:D код будет работать, и мне непонятно как код ссылается и определяет откуда берутся данные.Gopronotmore
Gopronotmore, Добрый день! Текстовые переменные немного иначе сравниваются на "<=". Поэтому приведённый Вами пример не подходит. Я макрос написал с учётом представленного Вами файла. Если будете использовать текстовые составляющие, удобно было бы создать словарь и переписать вот так, чтобы сильно код не менять: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic as Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4
n = 3 ' количество кружков ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row)) flg = -1 * (i <= oDic(Target.Text)) o(Target.Row)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i End Sub
[/vba] На самом деле, если бы было больше частей у кружков и надписи Ваши были однотипными, удобнее и заполнение словаря сделать циклом. И для задания цвета по выражению [vba]
Gopronotmore, Добрый день! Текстовые переменные немного иначе сравниваются на "<=". Поэтому приведённый Вами пример не подходит. Я макрос написал с учётом представленного Вами файла. Если будете использовать текстовые составляющие, удобно было бы создать словарь и переписать вот так, чтобы сильно код не менять: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic as Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4
n = 3 ' количество кружков ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row)) flg = -1 * (i <= oDic(Target.Text)) o(Target.Row)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i End Sub
[/vba] На самом деле, если бы было больше частей у кружков и надписи Ваши были однотипными, удобнее и заполнение словаря сделать циклом. И для задания цвета по выражению [vba]
это гениально, вот что значит мой дилетантский уровень не дает мне понять, что можно было просто добавить значения!!!
Спасибо Вам большое, очень помогли и + к карме!
Просто, когда сталкиваюсь с проблемой, стараюсь как можно проще выложить пример, а после уже что бы разобраться начинаю его доделывать так как надо, что бы понимать что происходит в коде.
Но тут столкнулся с тем, что просто не смог доделать. Значение флага изменил как надо, а надпись не добавил, но Вы дали очень оригинальный способ избежать этого в будущем, сделав объектный словарь по значениям.
У меня конечно была идея сделать через условное форматирование, а значения оставить, но это уже больше от безысходности.
А если будет больше кружков, я примерно понимаю о чем вы говорите, но я бы не смог это сделать.
Я если честно не понимаю как эта строка вообще работает
У меня пока простейшее понимание VBA. Я не программист =) по этому циклы для меня и массивы темный лес.
Roman777,
это гениально, вот что значит мой дилетантский уровень не дает мне понять, что можно было просто добавить значения!!!
Спасибо Вам большое, очень помогли и + к карме!
Просто, когда сталкиваюсь с проблемой, стараюсь как можно проще выложить пример, а после уже что бы разобраться начинаю его доделывать так как надо, что бы понимать что происходит в коде.
Но тут столкнулся с тем, что просто не смог доделать. Значение флага изменил как надо, а надпись не добавил, но Вы дали очень оригинальный способ избежать этого в будущем, сделав объектный словарь по значениям.
У меня конечно была идея сделать через условное форматирование, а значения оставить, но это уже больше от безысходности.
А если будет больше кружков, я примерно понимаю о чем вы говорите, но я бы не смог это сделать.
Я если честно не понимаю как эта строка вообще работает
[/vba] По сути flg - значение целочисленное, а [vba]
Код
(i <= oDic(Target.Text))
[/vba] значение булевое. Зная, что в VBA булевый true = -1 (целочисленному) и булевый false = 0 (целочисленному), макрос, в зависимости от условия (i <= oDic(Target.Text)) записывает в flg 0 и 1 (делая неявное преобразование типов). Ну а уже в случае, когда у нас 0 в выражении [vba]
Код
112 * flg + 255 * (1 - flg)
[/vba] отвалится левая часть (останется 255), а в случае flg = 1 отвалится правая часть, тогда значение для красного цвета станет 112. Собственно и получается либо RGB(255,255,255) - RGB белого цвета либо RGB(112,244,125) - RGB Ваш салатовый цвет =) [p.s.]
Цитата
У меня пока простейшее понимание VBA. Я не программист =) по этому циклы для меня и массивы темный лес.
у меня так же было лет 5 назад. А этот ресурс (и многие, в особенности, отзывчивые люди тут, дали очень-очень хороший старт, что в итоге повлияло даже на смену профессии =)[/p.s.]
[/vba] По сути flg - значение целочисленное, а [vba]
Код
(i <= oDic(Target.Text))
[/vba] значение булевое. Зная, что в VBA булевый true = -1 (целочисленному) и булевый false = 0 (целочисленному), макрос, в зависимости от условия (i <= oDic(Target.Text)) записывает в flg 0 и 1 (делая неявное преобразование типов). Ну а уже в случае, когда у нас 0 в выражении [vba]
Код
112 * flg + 255 * (1 - flg)
[/vba] отвалится левая часть (останется 255), а в случае flg = 1 отвалится правая часть, тогда значение для красного цвета станет 112. Собственно и получается либо RGB(255,255,255) - RGB белого цвета либо RGB(112,244,125) - RGB Ваш салатовый цвет =) [p.s.]
Цитата
У меня пока простейшее понимание VBA. Я не программист =) по этому циклы для меня и массивы темный лес.
у меня так же было лет 5 назад. А этот ресурс (и многие, в особенности, отзывчивые люди тут, дали очень-очень хороший старт, что в итоге повлияло даже на смену профессии =)[/p.s.]Roman777
Много чего не знаю!!!!
Сообщение отредактировал Roman777 - Суббота, 02.02.2019, 14:16
Gopronotmore, Пошагово пробегайте используя F8 в окне VBA, так будет легче понять, что куда нужно дописать. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic As Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4
n = 5 ' количество кружков i0 = 2 'начинаем со второй строки ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row - i0 + 1)) flg = -1 * (i <= oDic(Target.Text)) o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i End Sub
[/vba]
Gopronotmore, Пошагово пробегайте используя F8 в окне VBA, так будет легче понять, что куда нужно дописать. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic As Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4
n = 5 ' количество кружков i0 = 2 'начинаем со второй строки ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row - i0 + 1)) flg = -1 * (i <= oDic(Target.Text)) o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i End Sub
Gopronotmore, Вы же файл прислали, Ваши графические элементы начинаются со 2-й строки. Target.Row равен строке текущей ячейки. Если изменяете в данный момент A2, то будет равен численно 2.
Gopronotmore, Вы же файл прислали, Ваши графические элементы начинаются со 2-й строки. Target.Row равен строке текущей ячейки. Если изменяете в данный момент A2, то будет равен численно 2.Roman777
Roman777, ну как я понимаю это значение строки, откуда начинается отсчет. Должно быть с i0 = 2, но там +1 значение + еще значение с Target.Row
Roman777, ну как я понимаю это значение строки, откуда начинается отсчет. Должно быть с i0 = 2, но там +1 значение + еще значение с Target.RowGopronotmore
Сообщение отредактировал Gopronotmore - Понедельник, 04.02.2019, 14:44
Roman777, ну так получается с 1 строки же должно начинаться, а начинается со 2. Пытаюсь понять логику расчета ))). Получается 1 а начинается со 2 строки а по идее должно быть 2, что бы со 2 строки начинался расчет, или я что-то не так понимаю?
Roman777, ну так получается с 1 строки же должно начинаться, а начинается со 2. Пытаюсь понять логику расчета ))). Получается 1 а начинается со 2 строки а по идее должно быть 2, что бы со 2 строки начинался расчет, или я что-то не так понимаю?Gopronotmore
[/vba] Массив маcсивов "o" представляет собой массив, каждый элемент которого состоит из массива, элементами которого уже являются ссылки на объекты shape. У Вас 1 кружок - это 4 элемента. Вот и выходит массив кружков. Каждый элемент такого массива является в свою очередь массивом (в данном случае четвертинок). [vba]
Код
Target.Row - i0 + 1
[/vba] обращается к некоторому элементу массива o (коим является кружок (который в свою очередь имеет 4 четверти)). У Вас, когда Вы начинаете со второй строки, напротив стоит первый элемент массива кружков. Вот и получается, для 2й строки мы обращается в первый элемент массива кружков - к первому кружку, а уже "i" определяет к какой секции кружка.
[vba]
Код
o(Target.Row - i0 + 1)(i)
[/vba] Массив маcсивов "o" представляет собой массив, каждый элемент которого состоит из массива, элементами которого уже являются ссылки на объекты shape. У Вас 1 кружок - это 4 элемента. Вот и выходит массив кружков. Каждый элемент такого массива является в свою очередь массивом (в данном случае четвертинок). [vba]
Код
Target.Row - i0 + 1
[/vba] обращается к некоторому элементу массива o (коим является кружок (который в свою очередь имеет 4 четверти)). У Вас, когда Вы начинаете со второй строки, напротив стоит первый элемент массива кружков. Вот и получается, для 2й строки мы обращается в первый элемент массива кружков - к первому кружку, а уже "i" определяет к какой секции кружка.Roman777
Блин спасибо Вам огромное за разъяснение, теперь стало ясно откуда что берется.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic As Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") oDic.Add "Не начато", -1 oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4
n = 5 ' количество кружков i0 = 2 ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i
If i = -1 Then o(Target.Row)(i).Fill.ForeColor.RGB = vbRed Else For i = 1 To UBound(o(Target.Row - i0 + 1)) flg = -1 * (i <= oDic(Target.Text)) o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i End If End Sub
[/vba]
Последний вопрос и все. Почему кружки не красятся в красный цвет, если условие было выполнено???
Блин спасибо Вам огромное за разъяснение, теперь стало ясно откуда что берется.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic As Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") oDic.Add "Не начато", -1 oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4
n = 5 ' количество кружков i0 = 2 ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i
If i = -1 Then o(Target.Row)(i).Fill.ForeColor.RGB = vbRed Else For i = 1 To UBound(o(Target.Row - i0 + 1)) flg = -1 * (i <= oDic(Target.Text)) o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) Next i End If End Sub
[/vba]
Последний вопрос и все. Почему кружки не красятся в красный цвет, если условие было выполнено???Gopronotmore
Сообщение отредактировал Gopronotmore - Понедельник, 04.02.2019, 19:30
Не красит, не работает правило, полагаю что данное правило работало для цикла, а тут получается что цикл после исполняется при невыполнении условия.
Roman777,
Не красит, не работает правило, полагаю что данное правило работало для цикла, а тут получается что цикл после исполняется при невыполнении условия.Gopronotmore
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic As Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") oDic.Add "Отсутствует", -1 oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4
n = 5 ' количество кружков i0 = 2 ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row - i0 + 1)) If oDic(Target.Text) = -1 Then o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = vbRed Else flg = -1 * (i <= oDic(Target.Text)) o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) End If Next i End Sub
[/vba]
Или можно так попробовать, если будете добавлять условия других цветов (сразу для всего кружка в целом)
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic As Object, oColors As Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") 'oDict.Add "Какое-нибудь условие на все части кружка", -2 oDic.Add "Отсутствует", -1 oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4 'словарь цветов Set oColors = CreateObject("Scripting.Dictionary") 'oColors.Add "Какое-нибудь условие на все части кружка", -2 oColors.Add "Отсутствует", RGB(255, 0, 0) oColors.Add "Не выполнено", RGB(255, 255, 255) oColors.Add "Выполнено 25%", RGB(112, 244, 125) oColors.Add "Выполнено 50%", RGB(112, 244, 125) oColors.Add "Выполнено 75%", RGB(112, 244, 125) oColors.Add "Выполнено 100%", RGB(112, 244, 125)
n = 5 ' количество кружков i0 = 2 ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row - i0 + 1)) If oDic(Target.Text) < 0 Then o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = oColors(Target.Text) 'vbRed Else flg = -1 * (i <= oDic(Target.Text)) o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = oColors(Target.Text) * flg + (1 - flg) * RGB(255, 255, 255) End If Next i End Sub
[/vba]
Gopronotmore, [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic As Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") oDic.Add "Отсутствует", -1 oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4
n = 5 ' количество кружков i0 = 2 ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row - i0 + 1)) If oDic(Target.Text) = -1 Then o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = vbRed Else flg = -1 * (i <= oDic(Target.Text)) o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = RGB(112 * flg + 255 * (1 - flg), 244 * flg + 255 * (1 - flg), 125 * flg + 255 * (1 - flg)) End If Next i End Sub
[/vba]
Или можно так попробовать, если будете добавлять условия других цветов (сразу для всего кружка в целом)
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim o(), subO() As Shape Dim n As Long, i&, j&, k& Dim flg As Integer Dim oDic As Object, oColors As Object 'Создание словаря, где определяются значения (соответствия текста-значению): Set oDic = CreateObject("Scripting.Dictionary") 'oDict.Add "Какое-нибудь условие на все части кружка", -2 oDic.Add "Отсутствует", -1 oDic.Add "Не выполнено", 0 oDic.Add "Выполнено 25%", 1 oDic.Add "Выполнено 50%", 2 oDic.Add "Выполнено 75%", 3 oDic.Add "Выполнено 100%", 4 'словарь цветов Set oColors = CreateObject("Scripting.Dictionary") 'oColors.Add "Какое-нибудь условие на все части кружка", -2 oColors.Add "Отсутствует", RGB(255, 0, 0) oColors.Add "Не выполнено", RGB(255, 255, 255) oColors.Add "Выполнено 25%", RGB(112, 244, 125) oColors.Add "Выполнено 50%", RGB(112, 244, 125) oColors.Add "Выполнено 75%", RGB(112, 244, 125) oColors.Add "Выполнено 100%", RGB(112, 244, 125)
n = 5 ' количество кружков i0 = 2 ReDim o(1 To n) ReDim subO(1 To 4) ' 4 части кружка For i = 1 To n For j = 1 To UBound(subO) k = k + 1 Set subO(j) = ActiveSheet.Shapes("_o" & k) Next j o(i) = subO Next i If Target.Cells.Count > 1 Then Exit Sub If Target.Value = 0 Then intCorol = vbWhite End If For i = 1 To UBound(o(Target.Row - i0 + 1)) If oDic(Target.Text) < 0 Then o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = oColors(Target.Text) 'vbRed Else flg = -1 * (i <= oDic(Target.Text)) o(Target.Row - i0 + 1)(i).Fill.ForeColor.RGB = oColors(Target.Text) * flg + (1 - flg) * RGB(255, 255, 255) End If Next i End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
