Что нового?

Welcome to Цифровая крепость / Digital Fortress

Join us now to get access to all our features. Once registered and logged in, you will be able to create topics, post replies to existing threads, give reputation to your fellow members, get your own private messenger, and so, so much more. It's also quick and totally free, so what are you waiting for?

Ask question

Ask Questions and Get Answers from Our Community

Answer

Answer Questions and Become an Expert on Your Topic

Contact Staff

Our Experts are Ready to Answer your Questions

Excel Макрос для изменения цвета фигуры в зависимости от данных в таблице - VBA

Krystofer

Юнга
Регистрация
22.08.2020
Сообщения
24 373
Реакции
0
Баллы
5 005
Credits
160
Native language | Родной язык
Русский
Приветствую!
Есть задача создать интерактивную карту по регионам, цвет которых будет меняться в зависимости от данных в таблице.
Получилось нечто такое монструозное, но работающее. Это только часть, для двух регионов, а их больше 10. Как можно модифицировать макрос?

Как увидеть ссылки? | How to see hidden links?

Кликните здесь для просмотра всего текста


Sub смена_цвета()

ActiveSheet.Shapes.Range(Array("Пенжинский")).Select

If (Range("R14")) >= 70 Then

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0
.Solid
End With

ElseIf (Range("R14")) >= 50 Then

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.400000006
.Transparency = 0
.Solid
End With

ElseIf (Range("R14")) >= 30 Then

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent4
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.400000006
.Transparency = 0
.Solid
End With

ElseIf (Range("R14")) < 30 Then

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent6
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.400000006
.Transparency = 0
.Solid
End With
End If

ActiveSheet.Shapes.Range(Array("Олюторский")).Select

If (Range("R15")) >= 70 Then

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0
.Solid
End With

ElseIf (Range("R15")) >= 50 Then

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent2
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.400000006
.Transparency = 0
.Solid
End With

ElseIf (Range("R15")) >= 30 Then

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent4
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.400000006
.Transparency = 0
.Solid
End With

ElseIf (Range("R15")) < 30 Then

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent6
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.400000006
.Transparency = 0
.Solid
End With
End If


Изображения
Тип файла: jpg
Как увидеть ссылки? | How to see hidden links? (230.0 Кб)
 
shape1
shape2
shape3
shape4
shape7
shape8