Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Изменить цвет фигур, Изменить цвет фигур в соответствие со значениями в сводной таблице
 
#1
16.05.2024 16:37:15
Добрый день.
Прошу помочь со следующим вопросом.
Есть сводная таблица, в которой в столбце "ММ" идут значения от 1 до какого-то значения. Последнее значение может меняться. А вот внутри значения всегда идут подряд без пропусков и без повторений. То есть если последнее значение 100, значит и будет 100 строк.

При этом есть фигуры, в которых текст всегда соответствует какому-то номеру. Если в сводной 100 строк, значит и фигур будет 100 и каждая будет называться 1, 2 и т.д.

Было бы неплохо, чтобы при нажатии на кнопку "Обновить" фигуры закрашивались в соответствие со значениями сводной таблицы.
Цвета только 2. Если свободно - цвет Красный, если занято - цвет Зеленый.
Текст фигур всегда совпадает с номером с колонке "ММ".
 
 
 
#2
16.05.2024 17:00:05
Код
Sub ColorShape()
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim arr As Variant
    arr = Range("A8:B27").Value

    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        Select Case arr(ya, 2)
        Case "СВОБОДНО"
            dic.Item(CStr(arr(ya, 1))) = RGB(0, 255, 0)
        Case "ЗАНЯТО"
            dic.Item(CStr(arr(ya, 1))) = RGB(255, 0, 0)
        End Select
    Next

    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        If dic.Exists(sh.TextFrame2.TextRange.Characters.Text) Then
            sh.Fill.ForeColor.RGB = dic.Item(sh.TextFrame2.TextRange.Characters.Text)
'        Else
'            sh.Fill.ForeColor.RGB = RGB(200, 200, 200)
        End If
    Next
End Sub
 
 
 
#3
17.05.2024 10:50:44
Спасибо большое. Но есть еще вопрос.
Т.к. у меня сводная таблица не всегда одинаковая, а может увеличиваться, то при текущем коде мне всегда придется вручную менять рейндж, при каждом изменении. Хотелось бы этого избежать. И поменять вот эту строку
arr = Range("A8:B27").Value

Я поискал по форумам, нашел такое решение.
    Dim pt As PivotTable
    Dim rg As Range
    Set pt = Worksheets("ВИЗУАЛ").PivotTables("Сводная таблица4")
    Set rg = pt.DataBodyRange
   
   Dim arr As Variant
   'arr = Range("A8:B27").Value
   arr = rg.Value

Но я получаю ошибку "subscript out of range". Посмотрел, эта ошибка означает, что отсутствует или неправильная переменная. Я так понимаю, я названия листа или сводной указал неверно. А как правильно? Крутил по-разному, но каждый раз не так как надо.
 
 
 
#4
17.05.2024 10:59:48
Код
arr = Worksheets("ВИЗУАЛ").PivotTables("Сводная таблица4").RowRange.Value
Скрытый текст
 
 
 
#5
17.05.2024 11:05:20
Аааа, не DataBodyRange, а RowRange.
Спасибо огромное за помощь.
 
 
 
Страницы: 1
Наверх