Заливка строк при изменении даты

[shoy]

Уважаемые, пожалуйста, помогите построить макрос, который смог бы разными цветами выделять строки с разными датами.
Уточню: Если дата одинаковая в строках цвет у них одинаковый.
Как только сменилась дата, цвет сменился.

[Elixi]

Цветов вам хочется сколько? Два достаточно?
Свою попытку что-то сделать вы не показали.
Если никто не знает с чем вам не везёт, не ясно с чем помогать, где начинать.
Без этого, думаю, вряд ли кто-то начнёт именно помогать.
Также не ясно, достаточно ли вам залить цветом таблицу в первичном виде,
или вы планируете делать это с учётом фильтрации данных.

[shoy]

Я не смогу сам написать такой макрос, поэтому обратился сюда.
Отыскал вот такой макрос, но он отрабатывает не так как задумано.
1. Нужно заливать всю строку в UsedRange, а заливается только ячейка
2. И в этом макросе ищется дубликат ячейки, а нужно чтобы одинаковые даты (одна или много) закрашивались одним одинаковым цветом
3. и закрашиваются только дубликаты, а надо чтобы каждая строка
4. и если сменилась дата, то и цвет сменялся

Sub ÂûäåëèòüÄóáëèêàòûÐàçíûìèÖâåòàìè()
    On Error Resume Next
    ' ìàññèâ öâåòîâ, èñïîëüçóåìûõ äëÿ çàëèâêè ÿ÷ååê-äóáëèêàòîâ
   Colors = Array(12900829, 15849925, 14408946, 14610923, 15986394, 14281213, 14277081, _
                   9944516, 14994616, 12040422, 12379352, 15921906, 14336204, 15261367, 14281213)

    Dim coll As New Collection, dupes As New Collection, _
        cols As New Collection, ra As Range, cell As Range, n&
    Err.Clear: Set ra = Intersect(Selection, ActiveSheet.UsedRange)
    If Err Then Exit Sub

    ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False
    For Each cell In ra.Cells ' çàïîìèíàåì çíà÷åíèå äóáëèêàòîâ â êîëëåêöèè dupes
       Err.Clear: If Len(Trim(cell)) Then coll.Add CStr(cell.Value), CStr(cell.Value)
        If Err Then dupes.Add CStr(cell.Value), CStr(cell.Value)
    Next cell
    For i& = 1 To dupes.Count ' çàïîëíÿåì êîëëåêöèþ cols öâåòàìè äëÿ ðàçíûõ äóáëèêàòîâ
       n = n Mod (UBound(Colors) + 1): cols.Add Colors(n), dupes(i): n = n + 1
    Next
    For Each cell In ra.Cells ' îêðàøèâàåì ÿ÷åéêè, åñëè äëÿ å¸ çíà÷åíèÿ íàçíà÷åí öâåò
      cell.Interior.Color = cols(CStr(cell.Value))
      ' cell.EntireRow.Interior.Color = cols(CStr(cell.Value))
    Next cell
    Application.ScreenUpdating = True
End Sub

[Aleksandr H.]

Сколько дат будет? 56 цветов достаточно для идентификации?

[Elixi]

Если вы уже отискали такой макрос то можно попытаться приспособить и его.

дополните в нём:

Dim rw As Range

замените строку:

Err.Clear: Set ra = Intersect(Selection, ActiveSheet.UsedRange)

строкой:

Err.Clear: Set ra = Intersect(Range(Cells(1, Selection.Column), Cells(Rows.Count, Selection.Column)), ActiveSheet.UsedRange)

замените строку:

ra.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False

строкой:

ActiveSheet.UsedRange.Interior.ColorIndex = xlColorIndexNone: Application.ScreenUpdating = False

замените строку:

cell.Interior.Color = cols(CStr(cell.Value))

строками:

Set rw = Intersect(Range(Cells(cell.Row, 1), Cells(cell.Row, Columns.Count)), ActiveSheet.UsedRange)
    rw.Interior.Color = cols(CStr(cell.Value))

и попробуйте. Если что-то пойдёт не так, напишите и приложите файл с макросом.