Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Тепловая карта для ячеек в которых написан текст, по числовым данным из других ячеек
 
Добрый день!
Помогите сделать тепловую карту, задача такая: в ячейках A1-A16 есть имена, им соответствует числа в ячейках B1-B16. Нужно сделать тепловую карту для имен, по значениям которые имеются в B1-B16.
Пример прикрепляю.
 
Доброе время суток
Цитата
dim284 написал:
Помогите
Чем?
 
только макросом.

Код
Private Sub Worksheet_Change(ByVal Target As Range)
Const SRange = "A1:B16"
Const DRange = "d17:g20"
If Not Intersect(Target, Range(DRange)) Is Nothing Or _
    Not Intersect(Target, Range(SRange)) Is Nothing Then
    On Error Resume Next
    For Each cell In Range(DRange)
        cell.Interior.color = Range(SRange).Find(What:=cell.Value, LookAt:=xlWhole).Offset(, 1).DisplayFormat.Interior.color
        If Err <> 0 Then
            Err.Clear
            cell.Interior.color = vbWhite
        End If
    Next
End If
End Sub



Ну или для лимита в 10 строк :-)
Скрытый текст
Изменено: БМВ - 15 Апр 2020 19:35:46
По вопросам из тем форума, личку не читаю.
 
Понятно. Спасибо!
 
Ещё вариант :)
Изменено: _Igor_61 - 15 Апр 2020 20:44:26
 
БМВ Вы не могли бы скинуть файл с этим макросом - дело в том, что я  первый раз вижу Private Sub, намучался с ним и не понимаю как  использовать. Или объясните пожалуйста, я походу соображу.
_Igor_61 Ваш ответ мне очень нравится. Я числа убрал поменяв формат ячеек на ";;;" и стало как мне и надо было. Спасибо!
Изменено: dim284 - 16 Апр 2020 10:59:45
 
Цитата
dim284 написал:
я  первый раз вижу Private Sub, намучался с ним и не понимаю как  использовать
Скопируйте код и вставьте его в модуль листа.
Как найти модуль листа: правый клик по ярлычку листа - Исходный текст.
 
ну если
Цитата
dim284 написал:
и стало как мне и надо было
и не надо красить именно квадрат с текстовыми значениями. то используйте вариант  из #5.
По вопросам из тем форума, личку не читаю.
 
БМВ в Вашем файле работает, а в моем варианте нет. :( Я этот код куда только не вставлял: и в модуль листа, и в модуль книги, и в PersonalXLSB, и в сам лист!, и в соседний листок, и в соседнюю книгу... все одно и тоже. Посмотрите пожалуйста, что не так, файл прикрепляю.
Стоит вроде бы на листе правильно, как в Вашем файле, но почему-то не работает.
Изменено: dim284 - 16 Апр 2020 15:16:30
 
Верните форматироване в столбец B - заработает. Оно ж от туда берет цвет ну и для первого раза нужно поменять что-то в данных, все перестроит.
По вопросам из тем форума, личку не читаю.
 
Колдовство! Работает шайтан машина, работает :)))
Спасибо огромное БМВ! Ваш метод чуть лучше метода _Igor_61, так как не требует создавать поверх ячеек матрицу с буквами.
Всем спасибо! (Реверанс.)
 
dim284, никогда не делайте поспешных выводов :)
Цитата
dim284 написал:
БМВ! Ваш метод чуть лучше метода _Igor_61,
Не чуть а в принципе. Мне было скучно на карантине и было много времени, решил порисовать прямоугольники ради прикола и очень удивился что Вы это восприняли как решение а не как шутку.. :)  Несколько строк кода  гораздо эффективней 16-и графических объектов. Изучайте Excel, там есть очень много неожиданного и удивительного!  :)  
 
Цитата
_Igor_61 написал:
Не чуть а в принципе.
ну справедливости ради не без изъяна ибо при смене формата и без дополнительных ухищьрений ничего не запустится и надо дорабатывать.
По вопросам из тем форума, личку не читаю.
 
Михаил, Вы меня спровоцировали вот этим:
Цитата
БМВ написал:
только макросом
:)
Вот за что я люблю этот сайт! Есть где получить знания и есть где пошутить!
 
_Igor_61, ну от меня можно такой диагноз получить только в крайнем случае :-). Естественно полного соответствия заданию.
По вопросам из тем форума, личку не читаю.
 
Друзья, а если у меня два таких макроса как в сообщении #3,как мне объединить их в один, или запускать два с разными именами по очереди на одном листе? Понимаю, что подобные сообщения есть на страницах интернета, но что-то у меня никак не получается. Подскажите пожалуйста.
 
Нужно в одном этом предусмотреть те или иные действия.
По вопросам из тем форума, личку не читаю.
 
Всё мужики, спасибо, разобрался, с божьей помощью. Через полтора часа мучений, я просто тупо увеличил диапозоны

Const SRange = "A1:B16"
Const DRange = "d17:g20"

и запихал целых три! подобные таблички. Вот что получилось (прикрепляю). Я - гений экселя! :)
Изменено: dim284 - 18 Апр 2020 19:28:01
 
Упс, код потерялся в файле. В общем вот так:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
Const SRange = "D6:E341"
Const DRange = "p2:ae31"
If Not Intersect(Target, Range(DRange)) Is Nothing Or _
    Not Intersect(Target, Range(SRange)) Is Nothing Then
    On Error Resume Next
    For Each cell In Range(DRange)
        cell.Interior.Color = Range(SRange).Find(What:=cell.Value, LookAt:=xlWhole).Offset(, 1).DisplayFormat.Interior.Color
        If Err <> 0 Then
            Err.Clear
            cell.Interior.Color = vbWhite
        End If
    Next
End If
End Sub
Страницы: 1
Читают тему (гостей: 2)
Наверх