Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для подсветки текущей даты в таблице
 
#1
11.07.2014 16:15:00
Имеется: столбец с датами
Задача: выделять мерцанием ячейки с текущей датой (изменением цвета например)

Условное форматирование не подходит так как таблица и так разукрашена всевозможными цветами.
На просторах интернета нашел такой макрос
Мерцающая ячейка в Excel:
Код
Sub BlinkingCell()
    Static intCalls As Integer
    If intCalls < 10 Then
     intCalls = intCalls + 1
     If Range("A1").Interior.Color <> RGB(255, 0, 0) Then
      Range("A1").Interior.Color = RGB(255, 0, 0)
     Else
      Range("A1").Interior.Color = RGB(0, 255, 0)
     End If
     Application.OnTime Now + TimeValue("00:00:01"), "BlinkingCell"
    Else
     Range("A1").Interior.ColorIndex = xlNone
     intCalls = 0
    End If
End Sub
Пытался сам подредактировать, но вставить условия так и не смог, не понимаю как сделать чтобы мерцала именно нужная ячейка с датой (сегодня)

Помогите сделать. Макрос должен автоматически выполнятся при запуске, если это возможно, или по кнопке впринципе можно. и ячейки должны всегда мерцать.
 
 
 
#2
11.07.2014 16:39:02
В модуль листа с проверяемой ячейкой, Должен срабатывать на активацию листа, не проверял
Код
Private Sub Worksheet_Activate()
    Static intCalls As Integer
    If [a1] = Date Then
        If intCalls < 10 Then
            intCalls = intCalls + 1
            If Range("A1").Interior.Color <> RGB(255, 0, 0) Then
                Range("A1").Interior.Color = RGB(255, 0, 0)
            Else
                Range("A1").Interior.Color = RGB(0, 255, 0)
            End If
        Application.OnTime Now + TimeValue("00:00:01"), "BlinkingCell"
        Else
            Range("A1").Interior.ColorIndex = xlNone
            intCalls = 0
        End If
    End If

End Sub
Изменено: Sanja - 11.07.2014 16:44:50
Согласие есть продукт при полном непротивлении сторон
 
 
 
#3
11.07.2014 20:29:05
Код
 Private Sub Worksheet_Activate()
    Static intCalls As Integer
    If [a1] = Date Then
maska:
        If intCalls < 10 Then
            intCalls = intCalls + 1
            If Range("A1").Interior.Color <> RGB(255, 0, 0) Then
                Range("A1").Interior.Color = RGB(255, 0, 0)
            Else
                Range("A1").Interior.Color = RGB(0, 255, 0)
            End If
      Application.Wait (Now + TimeValue("0:00:01")): GoTo maska
        Else
            Range("A1").Interior.ColorIndex = xlNone
            intCalls = 0
        End If
    End If
 
End Sub
подредактировал код от Sanja, надеюсь не заругают :D
Если очень захотеть - можно в космос полететь ;)
 
 
 
#4
12.07.2014 01:14:13
вы делаете проверку даты только в ячейка А1, посмотрите внимание на задачку а не на код)
нужна проверка в целом столбце или диапазоне А1:А10 например, причем сегодняшняя дата например может быть в нескольких ячейках в этом столбце

Код я могу лишь описать:
начало
ЕСЛИ в столбце А имеется сегодняшняя дата ТО
     заполнить ячейки с сегодняшней датой цветом, затем другим, и еще другим (циклично)
ИНАЧЕ не делать ни каких действий с ячейками
конец

наверно надо сначала писать проверку столбца на наличие текущих дат, затем возвращать в функцию адреса ячеек, и уже к этим адресам ячеек применять тот код что имеется выше
Код
Range("некая ячейка".Interior.Color = RGB(255, 0, 0)
Изменено: venom51 - 12.07.2014 01:20:25
 
 
 
#5
12.07.2014 01:37:29
Цитата
venom51 пишет: заполнить ячейки с сегодняшней датой цветом, затем другим, и еще другим (циклично)
Если ячеек с текущей датой много, то может просто не хватить цветов))
 
 
 
#6
12.07.2014 09:54:18
Работает по кнопочке, по первому столбцу!
Код
   Sub test()
    Static intCalls As Integer
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 1) = Date Then adr = adr & Cells(i, 1).Address & ","
    Next 
if adr="" then Exit Sub
    adr = Left(adr, Len(adr) - 1)
maska:
        If intCalls < 10 Then
            intCalls = intCalls + 1
            If Range(adr).Interior.Color <> RGB(255, 0, 0) Then
                Range(adr).Interior.Color = RGB(255, 0, 0)
            Else
                Range(adr).Interior.Color = RGB(0, 255, 0)
            End If
      Application.Wait (Now + TimeValue("0:00:01")): GoTo maska
        Else
            Range(adr).Interior.ColorIndex = xlNone
            intCalls = 0
        End If
End Sub
Изменено: lexey_fan - 12.07.2014 09:55:27
Если очень захотеть - можно в космос полететь ;)
 
 
 
#7
15.07.2014 18:21:43
я сломал мозг но так и не понял как применить данный макрос к столбцу "S" 19-ому по счету(((
не силен я в коде совсем

что тут надо поменять чтобы адрес присвоить к столбцу S ?
Код
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
    If Cells(i, 1) = Date Then adr = adr & Cells(i, 1).Address & ","
 
 
 
#8
15.07.2014 18:37:21
Бедный мозг, все его норовят сломать. Внемлите:
Код
Cells(НОМЕР_СТРОКИ, НОМЕР_СТОЛБЦА)

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#9
29.10.2019 13:11:27
Как жаль что тема старая( Но вдруг кто-то заметит. Код Работает Шикарно, но как сделать так, чтобы он подсвечивал диапазон дат, до которых осталось менее 30 дней?
 
 
 
Страницы: 1
Наверх