Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 25.03.2020, 01:31   #1
shoy
Новичок
Джуниор
 
Регистрация: 30.08.2016
Сообщений: 2
По умолчанию Заливка строк при изменении даты

Уважаемые, пожалуйста, помогите построить макрос, который смог бы разными цветами выделять строки с разными датами.
Уточню: Если дата одинаковая в строках цвет у них одинаковый.
Как только сменилась дата, цвет сменился.
Вложения
Тип файла: xlsx !ПримерПоСтрокам.xlsx (12.3 Кб, 5 просмотров)
shoy вне форума Ответить с цитированием
Старый 27.03.2020, 23:03   #2
Elixi
Форумчанин
 
Регистрация: 10.05.2019
Сообщений: 163
По умолчанию

Цветов вам хочется сколько? Два достаточно?
Свою попытку что-то сделать вы не показали.
Если никто не знает с чем вам не везёт, не ясно с чем помогать, где начинать.
Без этого, думаю, вряд ли кто-то начнёт именно помогать.
Также не ясно, достаточно ли вам залить цветом таблицу в первичном виде,
или вы планируете делать это с учётом фильтрации данных.
Elixi вне форума Ответить с цитированием
Старый 28.03.2020, 09:56   #3
shoy
Новичок
Джуниор
 
Регистрация: 30.08.2016
Сообщений: 2
По умолчанию

Я не смогу сам написать такой макрос, поэтому обратился сюда.
Отыскал вот такой макрос, но он отрабатывает не так как задумано.
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

Последний раз редактировалось shoy; 28.03.2020 в 09:59.
shoy вне форума Ответить с цитированием
Старый 28.03.2020, 14:08   #4
Aleksandr H.
2 the Nation Glory
Старожил
 
Аватар для Aleksandr H.
 
Регистрация: 27.05.2014
Сообщений: 3,289
По умолчанию

Сколько дат будет? 56 цветов достаточно для идентификации?
Кто умер, но не забыт, тот бессмертен.
Лао-Цзы.
Aleksandr H. вне форума Ответить с цитированием
Старый 28.03.2020, 18:48   #5
Elixi
Форумчанин
 
Регистрация: 10.05.2019
Сообщений: 163
По умолчанию

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

дополните в нём:
Код:
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))
и попробуйте. Если что-то пойдёт не так, напишите и приложите файл с макросом.

Последний раз редактировалось Elixi; 28.03.2020 в 18:54.
Elixi вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Сумма строки при изменении кол-ва строк Серёга0629 Microsoft Office Excel 4 19.08.2011 15:45
отображение даты последних изменении ketrik5 Microsoft Office Access 11 11.08.2011 20:18
заливка цветом строк ivan52agronom Microsoft Office Excel 12 13.02.2010 23:10
Заливка - как контроль просуммированных строк ZLOdeev Microsoft Office Excel 2 04.11.2008 15:40
заливка строк DBGrid'а antoniosm БД в Delphi 10 18.09.2007 09:19