Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос на закрашивание ячеек в зависимости от даты - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос на закрашивание ячеек в зависимости от даты (Макросы/Sub)
Макрос на закрашивание ячеек в зависимости от даты
gizon Дата: Суббота, 11.02.2017, 16:43 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 16
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте, уважаемые гуру Excel. Очень прошу Вас помочь подкорректировать макрос. Он работает, но не совсем так как задумано. Проблема в том, что он неправильно воспринимает даты с названий столбцов и потому работает некорректно.
Если даты одного года, то проблем нет, но у меня большой разброс, дела 2015 года не закрываются, приходится их указывать, а макрос понимает нормально только один год. Короче разброс идет 5 лет максимум, начиная с 2015 г.(получается рабочая зона с K:BR)
Суть макроса такова: закрашивание ячеек в зависимости от дат, которые расположены в столбце J, верхняя строка даты - начальная дата и по идее она закрашивает серым цветом ячейки до предыдущего месяца (если стоит 01.02.2016, то от начала столбца покроется серым цветом все до столбца "январь 2016"), вторая строка даты из столбца J закрашивает ячейки так: от серой ячейки 2 шага (белый цвет) после синий и до конечного месяца, последний месяц всегда синяя ячейка в не зависимости от того, что шаг собъётся. И последний момент, если в столбце H стоит значение ежемесячно, то ячейки становятся синими без шага, ежеквартально - с шагом.
Сейчас есть ошибки, взять даже первую строку дата стоит с 2016-2017 годы, а он начинает шаг с 2015.
Для удобства выведена кнопка "белым" для закрашивания всей рабочей зоны белым цветом.
Тема создана на другом сайте, но там никто пока не помог
http://www.planetaexcel.ru/forum....ot-daty
К сообщению приложен файл: 2467905.rar (60.6 Kb)
 
Ответить
СообщениеЗдравствуйте, уважаемые гуру Excel. Очень прошу Вас помочь подкорректировать макрос. Он работает, но не совсем так как задумано. Проблема в том, что он неправильно воспринимает даты с названий столбцов и потому работает некорректно.
Если даты одного года, то проблем нет, но у меня большой разброс, дела 2015 года не закрываются, приходится их указывать, а макрос понимает нормально только один год. Короче разброс идет 5 лет максимум, начиная с 2015 г.(получается рабочая зона с K:BR)
Суть макроса такова: закрашивание ячеек в зависимости от дат, которые расположены в столбце J, верхняя строка даты - начальная дата и по идее она закрашивает серым цветом ячейки до предыдущего месяца (если стоит 01.02.2016, то от начала столбца покроется серым цветом все до столбца "январь 2016"), вторая строка даты из столбца J закрашивает ячейки так: от серой ячейки 2 шага (белый цвет) после синий и до конечного месяца, последний месяц всегда синяя ячейка в не зависимости от того, что шаг собъётся. И последний момент, если в столбце H стоит значение ежемесячно, то ячейки становятся синими без шага, ежеквартально - с шагом.
Сейчас есть ошибки, взять даже первую строку дата стоит с 2016-2017 годы, а он начинает шаг с 2015.
Для удобства выведена кнопка "белым" для закрашивания всей рабочей зоны белым цветом.
Тема создана на другом сайте, но там никто пока не помог
http://www.planetaexcel.ru/forum....ot-daty

Автор - gizon
Дата добавления - 11.02.2017 в 16:43
Pelena Дата: Суббота, 11.02.2017, 19:53 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19163
Репутация: 4412 ±
Замечаний: ±

Excel 365 & Mac Excel
Проверьте так
[p.s.]На Планете тоже ссылку на кросс дайте[/p.s.]
К сообщению приложен файл: 7856232.rar (22.2 Kb)


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеПроверьте так
[p.s.]На Планете тоже ссылку на кросс дайте[/p.s.]

Автор - Pelena
Дата добавления - 11.02.2017 в 19:53
Manyasha Дата: Суббота, 11.02.2017, 20:15 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
еще вариант:
[vba]
Код
Sub cveta()
Dim lngI As Long
Dim lngJ As Long
Dim arrS() As String
    For lngI = 2 To Cells(Rows.Count, 10).End(xlUp).Row 'от 2-ой до последней заполненной ячейке по столбцу J
        arrS = Split(Trim(Cells(lngI, 10)), " - " & Chr(10)) 'разделяем содержимое ячейки на 2 даты
            If Cells(lngI, 8) = "ежемесячно" Then 'проверяем наличие условия
                'если да - то тупо красим в голубой все ячейки по строке от января до месяца из второй даты
                Cells(lngI, 10).Offset(0, 1).Resize(1, DateDiff("m", [k1], CDate(arrS(1))) + 1).Interior.ColorIndex = 37
            Else
                'если нет
                'красим промежуток от столбца К до столбца месяца из первой даты в серый
                'добавил проверку - если месяц первой даты - январь - не красим.
                Cells(lngI, 10).Offset(0, 1).Resize(1, DateDiff("m", [k1], CDate(arrS(0)))).Interior.ColorIndex = 15
                For lngJ = DateDiff("m", [k1], CDate(arrS(0))) + 3 To DateDiff("m", [k1], CDate(arrS(1))) + 1 Step 3
                    Cells(lngI, 10 + lngJ).Interior.ColorIndex = 37
                Next lngJ
                
                Cells(lngI, 11 + DateDiff("m", [k1], CDate(arrS(1)))).Interior.ColorIndex = 37
            End If
    Next lngI
End Sub
[/vba]

Закрасить весь диапазон белым можно одной строчкой:
[vba]
Код
Range("K2:BR27").Interior.ColorIndex = 2
[/vba]
К сообщению приложен файл: -1.xls (73.0 Kb)


ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениееще вариант:
[vba]
Код
Sub cveta()
Dim lngI As Long
Dim lngJ As Long
Dim arrS() As String
    For lngI = 2 To Cells(Rows.Count, 10).End(xlUp).Row 'от 2-ой до последней заполненной ячейке по столбцу J
        arrS = Split(Trim(Cells(lngI, 10)), " - " & Chr(10)) 'разделяем содержимое ячейки на 2 даты
            If Cells(lngI, 8) = "ежемесячно" Then 'проверяем наличие условия
                'если да - то тупо красим в голубой все ячейки по строке от января до месяца из второй даты
                Cells(lngI, 10).Offset(0, 1).Resize(1, DateDiff("m", [k1], CDate(arrS(1))) + 1).Interior.ColorIndex = 37
            Else
                'если нет
                'красим промежуток от столбца К до столбца месяца из первой даты в серый
                'добавил проверку - если месяц первой даты - январь - не красим.
                Cells(lngI, 10).Offset(0, 1).Resize(1, DateDiff("m", [k1], CDate(arrS(0)))).Interior.ColorIndex = 15
                For lngJ = DateDiff("m", [k1], CDate(arrS(0))) + 3 To DateDiff("m", [k1], CDate(arrS(1))) + 1 Step 3
                    Cells(lngI, 10 + lngJ).Interior.ColorIndex = 37
                Next lngJ
                
                Cells(lngI, 11 + DateDiff("m", [k1], CDate(arrS(1)))).Interior.ColorIndex = 37
            End If
    Next lngI
End Sub
[/vba]

Закрасить весь диапазон белым можно одной строчкой:
[vba]
Код
Range("K2:BR27").Interior.ColorIndex = 2
[/vba]

Автор - Manyasha
Дата добавления - 11.02.2017 в 20:15
gizon Дата: Суббота, 11.02.2017, 23:21 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 16
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Pelena, Manyasha, огромнейшее спасибо, нереально круто получилось. Всё протестировано, ошибок не выявлено, выбран вариант предложенный Pelenой.
Можно, пожалуйста, попросить Вас ещё добавить линии границ к закрашенным ячейкам, так понятнее получается.
К сообщению приложен файл: 4854170.jpg (30.0 Kb)


Сообщение отредактировал gizon - Суббота, 11.02.2017, 23:22
 
Ответить
СообщениеPelena, Manyasha, огромнейшее спасибо, нереально круто получилось. Всё протестировано, ошибок не выявлено, выбран вариант предложенный Pelenой.
Можно, пожалуйста, попросить Вас ещё добавить линии границ к закрашенным ячейкам, так понятнее получается.

Автор - gizon
Дата добавления - 11.02.2017 в 23:21
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос на закрашивание ячеек в зависимости от даты (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!