Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос на заливку ячеек цветом
 
#1
20.01.2016 00:13:21
Добрый день.

Мне нужно, чтобы на листе слово "один" окрашивалось в красный цвет, слово "два" в зеленый, слово "три" в желтый и т.д. И над каждой окрашенной ячейкой, в тот же цвет окрашивались 2 ячейки сверху.
И если текст в какой-либо ячейке изменил цвет, то также цвет текста меняется в двух ячейках сверху.

Я так понимаю это можно сделать только макросом. Может ли кто-нибудь помочь?
Изменено: Сергей Самсонов - 20.01.2016 00:16:11
 
 
 
#2
20.01.2016 00:20:01
Цитата
Сергей Самсонов написал:Мне нужно..Может ли кто-нибудь помочь?
С таким подходом СЮДА
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
20.01.2016 00:22:19
Цитата
Сергей Самсонов написал:
Может ли кто-нибудь помочь?
Чем именно? Вы даже файл не приложили. Получается, кто-то должен создать файл с данными и код написать. А что будете делать в это время Вы? И что будете делать потом, если кто-то все это сделает, но у Вас данные окажутся в других ячейках и вообще иначе все расположено?

В общем приложите пример со своими данными(несколько строк) и наглядно покажите как понять какие ячейки по какому принципу закрашивать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#4
20.01.2016 01:21:24
Извиняюсь. Исправлюсь. Но я пока не знаю как вообще подойти к данной задаче.

Нашел пока только функцию, которая в зависимости от цвета ячеек задает формулу.
Код
Function ifcolor(a As Range, b As Range)
    Dim i As Long
    i = a.Interior.color
        
    Select Case i
    Case Is = 255: ifcolor = a.Value + b.Value
    Case Is = 5287936: ifcolor = a.Value * b.Value
    Case Else: ifcolor = "нет цвета"
    End Select
        
End Function
Но мне нужно, чтобы в зависимости от текста в ячейке изменялась заливка самой ячейки и двух сверху. Пробовал условное форматирование, но для 1500 ячеек слишком некрасиво и тяжело выходит.
 
 
 
#5
20.01.2016 08:21:36
Файла-примера, видимо, не дождемся
Тогда попробуйте сами разобраться. Код в модуль листа
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(1)) Is Nothing Then
        If Target.Value = 555 Then
            Select Case Target.Row
                Case 1
                    r = 0
                Case 2
                    r = -1
                Case Else
                    r = -2
            End Select
            Range(Target, Target.Offset(r, 0)).Interior.Color = 65535
        End If
    End If
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#6
20.01.2016 16:48:20
Sanja, спасибо! Вы кудесник. Ваш код сейчас выглядит вот так:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A:AF")) Is Nothing Then
        
        If Target.Value = "" Then
            Select Case Target.Row
                Case 1
                    r = 0
                Case 2
                    r = -1
                Case Else
                    r = -2
            End Select
            Range(Target, Target.Offset(r, 0)).Interior.ColorIndex = xlNone
            Range(Target, Target.Offset(r, 0)).Font.ColorIndex = xlAutomatic
        End If
        
        If Target.Value = "444" Then
            Select Case Target.Row
                Case 1
                    r = 0
                Case 2
                    r = -1
                Case Else
                    r = -2
            End Select
            Range(Target, Target.Offset(r, 0)).Interior.Color = 255
            Range(Target, Target.Offset(r, 0)).Font.ColorIndex = xlAutomatic
        End If
    
    End If
End Sub
Остался один вопрос. Если я делаю изменения одновременно более, чем в одной ячейке (paste, delete) - возникает ошибка Runtime error '13': Type mismatch. Как это можно исправить?
 
 
 
#7
20.01.2016 18:01:50
Сначала написал, потом сделал.. Решил проблему с ошибкой так:
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A:AF")) Is Nothing Then
    On Error GoTo ExitSub
    ***
    End If
ExitSub:
End Sub
 
 
 
#8
20.01.2016 18:09:15
Цитата
Сергей Самсонов написал: Я так понимаю это можно сделать только макросом
Доброго времени суток! Не только макросом, насколько я понимаю из описанных требований несколько простых правил условного форматирования тоже можно применить.
 
 
 
Страницы: 1
Наверх