Подскажите, пожалуйста, как написать код для группировки столбцов с привязкой к значению в ячейке? Я новичок в VBA и буду благодарна любым идеям для решения данной задачи. Сама я пока не очень уверенно пишу коды - только самые простые комбинации; под конкретные же задачи - теряюсь.
Во вложении файл с нужным результатам на дату 11 января 2018. Сгруппировать нужно три диапазона в зависимости от изменяющейся даты.
В результате по макросу группировка должна складываться в зависимости от даты в ячейке А1 Пояснения для группировки по столбцам:
1) Диапазон столбцов (H:NH), - Группировка отсутствует в периоде, который заканчивается датой из ячейки A1, и начинается на 8 столбцов ранее, но не ранее, чем с начала диапазона. Т.е. если в ячейке А1 окажется дата 4 января 2018 - то без группировки будут 4 первых столбца, соответствующие 1-4 января. - Столбцы «до» и столбцы «после» несгруппированного периода в диапазоне должны быть сгруппированы и свернуты.
2) Диапазон столбцов (NJ:PJ), - Группировка отсутствует в период, который заканчивается неделей, содержащей дату из ячейки A1, и начинается на 4 столбца ранее, но не ранее, чем с начала диапазона (NJ:PJ). Т.е. максимально лишенными группировки в этом диапазоне могут быть 4 столбца, а если это первая неделя января, то 1 столбец. - Столбцы «до» и столбцы «после» несгруппированного периода в диапазоне должны быть сгруппированы и свернуты.
3) Диапазон столбцов (PL:PW) - Группировка отсутствует в период, который заканчивается месяцем, содержащим дату из ячейки A1, и начинается на 4 столбца ранее, но не ранее, чем с начала диапазона (PL:PW). Т.е. максимально лишенными группировки в этом диапазоне могут быть 4 столбца, а если это январь, то 1 столбец. - Столбцы «до» и столбцы «после» несгруппированного периода в диапазоне должны быть сгруппированы и свернуты.
Заранее спасибо!
Доброго дня, уважаемые знатоки VBA!
Подскажите, пожалуйста, как написать код для группировки столбцов с привязкой к значению в ячейке? Я новичок в VBA и буду благодарна любым идеям для решения данной задачи. Сама я пока не очень уверенно пишу коды - только самые простые комбинации; под конкретные же задачи - теряюсь.
Во вложении файл с нужным результатам на дату 11 января 2018. Сгруппировать нужно три диапазона в зависимости от изменяющейся даты.
В результате по макросу группировка должна складываться в зависимости от даты в ячейке А1 Пояснения для группировки по столбцам:
1) Диапазон столбцов (H:NH), - Группировка отсутствует в периоде, который заканчивается датой из ячейки A1, и начинается на 8 столбцов ранее, но не ранее, чем с начала диапазона. Т.е. если в ячейке А1 окажется дата 4 января 2018 - то без группировки будут 4 первых столбца, соответствующие 1-4 января. - Столбцы «до» и столбцы «после» несгруппированного периода в диапазоне должны быть сгруппированы и свернуты.
2) Диапазон столбцов (NJ:PJ), - Группировка отсутствует в период, который заканчивается неделей, содержащей дату из ячейки A1, и начинается на 4 столбца ранее, но не ранее, чем с начала диапазона (NJ:PJ). Т.е. максимально лишенными группировки в этом диапазоне могут быть 4 столбца, а если это первая неделя января, то 1 столбец. - Столбцы «до» и столбцы «после» несгруппированного периода в диапазоне должны быть сгруппированы и свернуты.
3) Диапазон столбцов (PL:PW) - Группировка отсутствует в период, который заканчивается месяцем, содержащим дату из ячейки A1, и начинается на 4 столбца ранее, но не ранее, чем с начала диапазона (PL:PW). Т.е. максимально лишенными группировки в этом диапазоне могут быть 4 столбца, а если это январь, то 1 столбец. - Столбцы «до» и столбцы «после» несгруппированного периода в диапазоне должны быть сгруппированы и свернуты.
Добрый день. Вариант без группировок, а просто скрытие ненужных столбцов [vba]
Код
Sub Ìàêðîñ()
Sheets(1).UsedRange.Columns.Hidden = False
On Error Resume Next
d = CDate(Right([a1], 10)) If Err Then MsgBox "íå ðàçîáðàë äàòó" Err.Clear Exit Sub End If
d_ = d - CDate("01.01.2018") If d_ > 8 Then Range(Cells(1, 8), Cells(1, d_)).EntireColumn.Hidden = True If d_ < 372 Then Range(Cells(1, d_ + 9), Cells(1, 372)).EntireColumn.Hidden = True
w = DatePart("ww", d, 2, 1) + 373 If w > 377 Then Range(Cells(1, 373), Cells(1, w - 4)).EntireColumn.Hidden = True If w < 426 Then Range(Cells(1, w + 1), Cells(1, 426)).EntireColumn.Hidden = True
m = Month(d) + 427 If m > 431 Then Range(Cells(1, 428), Cells(1, m - 4)).EntireColumn.Hidden = True If m < 439 Then Range(Cells(1, m + 1), Cells(1, 439)).EntireColumn.Hidden = True
End Sub
[/vba]
Добрый день. Вариант без группировок, а просто скрытие ненужных столбцов [vba]
Код
Sub Ìàêðîñ()
Sheets(1).UsedRange.Columns.Hidden = False
On Error Resume Next
d = CDate(Right([a1], 10)) If Err Then MsgBox "íå ðàçîáðàë äàòó" Err.Clear Exit Sub End If
d_ = d - CDate("01.01.2018") If d_ > 8 Then Range(Cells(1, 8), Cells(1, d_)).EntireColumn.Hidden = True If d_ < 372 Then Range(Cells(1, d_ + 9), Cells(1, 372)).EntireColumn.Hidden = True
w = DatePart("ww", d, 2, 1) + 373 If w > 377 Then Range(Cells(1, 373), Cells(1, w - 4)).EntireColumn.Hidden = True If w < 426 Then Range(Cells(1, w + 1), Cells(1, 426)).EntireColumn.Hidden = True
m = Month(d) + 427 If m > 431 Then Range(Cells(1, 428), Cells(1, m - 4)).EntireColumn.Hidden = True If m < 439 Then Range(Cells(1, m + 1), Cells(1, 439)).EntireColumn.Hidden = True
sboy, Это не совсем подходит, т.к. часто приходится в последствии разворачивать группировки в этом файле. Привыкла к "+". И почему-то начиная с дат февраля в предложенном Вами варианте скрывается также разделительный серый столбец между днями и неделями, что тоже не очень красиво визуально.
Но за идею спасибо! Попробую довести ее в своем коде до желаемого результата.
sboy, Это не совсем подходит, т.к. часто приходится в последствии разворачивать группировки в этом файле. Привыкла к "+". И почему-то начиная с дат февраля в предложенном Вами варианте скрывается также разделительный серый столбец между днями и неделями, что тоже не очень красиво визуально.
Но за идею спасибо! Попробую довести ее в своем коде до желаемого результата.Iren
Сообщение отредактировал Iren - Вторник, 16.01.2018, 14:00
Sub Макрос() On Error Resume Next ActiveSheet.Outline.ShowLevels ColumnLevels:=2 Sheets(1).UsedRange.Columns.Ungroup If Err Then Err.Clear
d = CDate(Right([a1], 10)) If Err Then MsgBox "не разобрал дату" Err.Clear Exit Sub End If
d_ = d - CDate("01.01.2018") + 8 If d_ > 15 Then Range(Cells(1, 8), Cells(1, d_ - 8)).EntireColumn.Group If d_ < 372 Then Range(Cells(1, d_ + 1), Cells(1, 372)).EntireColumn.Group
w = DatePart("ww", d, 2, 1) + 373 If w > 377 Then Range(Cells(1, 374), Cells(1, w - 4)).EntireColumn.Group If w < 426 Then Range(Cells(1, w + 1), Cells(1, 426)).EntireColumn.Group
m = Month(d) + 427 If m > 431 Then Range(Cells(1, 428), Cells(1, m - 4)).EntireColumn.Group If m < 439 Then Range(Cells(1, m + 1), Cells(1, 439)).EntireColumn.Group
ActiveSheet.Outline.ShowLevels ColumnLevels:=1 End Sub
Sub Макрос() On Error Resume Next ActiveSheet.Outline.ShowLevels ColumnLevels:=2 Sheets(1).UsedRange.Columns.Ungroup If Err Then Err.Clear
d = CDate(Right([a1], 10)) If Err Then MsgBox "не разобрал дату" Err.Clear Exit Sub End If
d_ = d - CDate("01.01.2018") + 8 If d_ > 15 Then Range(Cells(1, 8), Cells(1, d_ - 8)).EntireColumn.Group If d_ < 372 Then Range(Cells(1, d_ + 1), Cells(1, 372)).EntireColumn.Group
w = DatePart("ww", d, 2, 1) + 373 If w > 377 Then Range(Cells(1, 374), Cells(1, w - 4)).EntireColumn.Group If w < 426 Then Range(Cells(1, w + 1), Cells(1, 426)).EntireColumn.Group
m = Month(d) + 427 If m > 431 Then Range(Cells(1, 428), Cells(1, m - 4)).EntireColumn.Group If m < 439 Then Range(Cells(1, m + 1), Cells(1, 439)).EntireColumn.Group
ActiveSheet.Outline.ShowLevels ColumnLevels:=1 End Sub
Работая с выше указанным кодом, попыталась уйти от On Error Resume Next, т.к. пока опыт небольшой, боюсь пропускать ошибки ... мало ли что... Заменила [vba]
Код
Sheets(1).UsedRange.Columns.Ungroup If Err Then Err.Clear
[/vba] на [vba]
Код
Dim r_of_days As Range Set r_of_days = Range("H:PW") While r_of_days.EntireColumn.OutlineLevel > 1 r_of_days.EntireColumn.Ungroup Wend
[/vba]
Предполагала, что тогда в нужном мне диапазоне, до тех пор пока столбцы остаются сгруппированными, группировки будут очищаться. Однако, код не работает как нужно. Ошибок не выдает, но группировки не видит и ничего не очищает.
Где я ошиблась?
Подскажите, пожалуйста!
Работая с выше указанным кодом, попыталась уйти от On Error Resume Next, т.к. пока опыт небольшой, боюсь пропускать ошибки ... мало ли что... Заменила [vba]
Код
Sheets(1).UsedRange.Columns.Ungroup If Err Then Err.Clear
[/vba] на [vba]
Код
Dim r_of_days As Range Set r_of_days = Range("H:PW") While r_of_days.EntireColumn.OutlineLevel > 1 r_of_days.EntireColumn.Ungroup Wend
[/vba]
Предполагала, что тогда в нужном мне диапазоне, до тех пор пока столбцы остаются сгруппированными, группировки будут очищаться. Однако, код не работает как нужно. Ошибок не выдает, но группировки не видит и ничего не очищает.
Можно окружать в обработчик ошибок фрагмент кода, где ожидается ошибка. И если возникнет непредвиденная ошибка в другом месте, Вы об этом узнаете.
[vba]
Код
Sub Макрос() ActiveSheet.Outline.ShowLevels ColumnLevels:=2 On Error Resume Next Sheets(1).usedrange.Columns.Ungroup On Error GoTo 0
On Error Resume Next d = CDate(Right([a1], 10)) If Err Then MsgBox "не разобрал дату" Err.Clear Exit Sub End If On Error GoTo 0
d_ = d - CDate("01.01.2018") + 8 If d_ > 15 Then Range(Cells(1, 8), Cells(1, d_ - 8)).EntireColumn.Group If d_ < 372 Then Range(Cells(1, d_ + 1), Cells(1, 372)).EntireColumn.Group
w = DatePart("ww", d, 2, 1) + 373 If w > 377 Then Range(Cells(1, 374), Cells(1, w - 4)).EntireColumn.Group If w < 426 Then Range(Cells(1, w + 1), Cells(1, 426)).EntireColumn.Group
m = Month(d) + 427 If m > 431 Then Range(Cells(1, 428), Cells(1, m - 4)).EntireColumn.Group If m < 439 Then Range(Cells(1, m + 1), Cells(1, 439)).EntireColumn.Group
ActiveSheet.Outline.ShowLevels ColumnLevels:=1 End Sub
[/vba]
Можно окружать в обработчик ошибок фрагмент кода, где ожидается ошибка. И если возникнет непредвиденная ошибка в другом месте, Вы об этом узнаете.
[vba]
Код
Sub Макрос() ActiveSheet.Outline.ShowLevels ColumnLevels:=2 On Error Resume Next Sheets(1).usedrange.Columns.Ungroup On Error GoTo 0
On Error Resume Next d = CDate(Right([a1], 10)) If Err Then MsgBox "не разобрал дату" Err.Clear Exit Sub End If On Error GoTo 0
d_ = d - CDate("01.01.2018") + 8 If d_ > 15 Then Range(Cells(1, 8), Cells(1, d_ - 8)).EntireColumn.Group If d_ < 372 Then Range(Cells(1, d_ + 1), Cells(1, 372)).EntireColumn.Group
w = DatePart("ww", d, 2, 1) + 373 If w > 377 Then Range(Cells(1, 374), Cells(1, w - 4)).EntireColumn.Group If w < 426 Then Range(Cells(1, w + 1), Cells(1, 426)).EntireColumn.Group
m = Month(d) + 427 If m > 431 Then Range(Cells(1, 428), Cells(1, m - 4)).EntireColumn.Group If m < 439 Then Range(Cells(1, m + 1), Cells(1, 439)).EntireColumn.Group
ActiveSheet.Outline.ShowLevels ColumnLevels:=1 End Sub
Но что все-таки не так у меня с While? Может, какие-то ограничения есть, когда задается цикл? Чтобы мне понимать, в каких случаях можно пользоваться while, и с чем while не работает.
Спасибо! Полезно узнать про On Error GoTo 0
Но что все-таки не так у меня с While? Может, какие-то ограничения есть, когда задается цикл? Чтобы мне понимать, в каких случаях можно пользоваться while, и с чем while не работает.Iren
Откуда Вы "откопали" While - Wend. Если Вы только начинаете изучать VBA. то в современных справочниках не упоминается этот цикл. Было бы понятно, если Вы начали программировать лет 20 назад. Сейчас используются Do - Loop.
Откуда Вы "откопали" While - Wend. Если Вы только начинаете изучать VBA. то в современных справочниках не упоминается этот цикл. Было бы понятно, если Вы начали программировать лет 20 назад. Сейчас используются Do - Loop.Karataev
Сообщение отредактировал Karataev - Четверг, 18.01.2018, 17:04
Не совсем: Sub Разгруппировать() снимает только один уровень группировки столбцов, а не все. Я хотела полностью очистить столбцы области (H:PW) от всех группировок, чтобы цикл проверял диапазон снова и снова, до тех пор, пока уровень группировки>1
Karataev,
Не совсем: Sub Разгруппировать() снимает только один уровень группировки столбцов, а не все. Я хотела полностью очистить столбцы области (H:PW) от всех группировок, чтобы цикл проверял диапазон снова и снова, до тех пор, пока уровень группировки>1Iren
Месяца два назад начала изучать VBA с нуля по учебнику из интернета. Наверное, это был очень старый учебник) Но просто и понятно написанный. А теперь вот пытаюсь практиковаться.
Цитата
PS. Откуда Вы "откопали" While - Wend.
Месяца два назад начала изучать VBA с нуля по учебнику из интернета. Наверное, это был очень старый учебник) Но просто и понятно написанный. А теперь вот пытаюсь практиковаться.Iren
Поэтому я и предлагал в самом начале скрывать столбцы, а не группировать
Уважаемые, но задача-то сделать макрос, удобный для использования - такой, чтобы привычные ручные действия автоматизировать - а не подстраиваться под код. Работать удобнее и привычнее с группировками, а не со скрытыми столбцами.
Если, вариантов без On Error Resume нет, то вернусь к макросу из поста 4 и добавлю предложенный On Error Go to 0 Решение-то уже есть - код sboy. Извиняюсь, если назойлива: мне как новичку было интересно готовый код разобрать вдоль и поперек и максимально понять как он работает и как сделать аналог известными мне операторами, чтобы в дальнейшем мочь что-то самой.
Цитата
Поэтому я и предлагал в самом начале скрывать столбцы, а не группировать
Уважаемые, но задача-то сделать макрос, удобный для использования - такой, чтобы привычные ручные действия автоматизировать - а не подстраиваться под код. Работать удобнее и привычнее с группировками, а не со скрытыми столбцами.
Если, вариантов без On Error Resume нет, то вернусь к макросу из поста 4 и добавлю предложенный On Error Go to 0 Решение-то уже есть - код sboy. Извиняюсь, если назойлива: мне как новичку было интересно готовый код разобрать вдоль и поперек и максимально понять как он работает и как сделать аналог известными мне операторами, чтобы в дальнейшем мочь что-то самой.Iren
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
