Страницы: 1
RSS
Группировка строк, Нужно автоматически сгруппировать строки одним действием
 
Ребята, привет! Подскажите как быстро можно сгруппировать все белые строки одним действие? Их очень много, как видите, и вручную выделять и группировать - это мрак! Заранее всем просветлённым спасибо.
 
JERY, здравствуйте
Если преобразовать данные в нормальный вид и построить по ним штатную сводную, то в ней есть "встроенная группировка" и не надо ничего придумывать.
Если работать с тем, что есть, то только макрос
Изменено: Jack Famous - 04.08.2022 09:45:44
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Штатная сводная?
 
Попробуйте так:
Код
Sub Groupr()
Dim cl As Range, rng As Range, lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each cl In Range("A6:A" & lr)
    If cl.DisplayFormat.Interior.Color = 16777215 Then
        If rng Is Nothing Then Set rng = cl.Rows Else Set rng = Union(rng, cl.Rows)
    Else
        If Not rng Is Nothing Then rng.Rows.Group: Set rng = Nothing
    End If
Next
If Not rng Is Nothing Then rng.Rows.Group
Cells(1, 1).Select
ActiveSheet.Outline.ShowLevels RowLevels:=1
Application.ScreenUpdating = True
End Sub
Изменено: Msi2102 - 04.08.2022 09:56:40
 
Цитата
написал:
Попробуйте так:
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15  16      Sub   Groupr()    Dim   cl   As   Range, rng   As   Range, lr   As   Long    Application.ScreenUpdating =   False    lr = Cells(Rows.Count, 1).  End  (xlUp).Row    For   Each   cl   In   Range(  "A6:A"   & lr)          If   cl.DisplayFormat.Interior.Color = 16777215   Then              If   rng   Is   Nothing   Then   Set   rng = cl.Rows   Else   Set   rng = Union(rng, cl.Rows)          Else              If   Not   rng   Is   Nothing   Then   rng.Rows.Group:   Set   rng =   Nothing          End   If    Next    If   Not   rng   Is   Nothing   Then   rng.Rows.Group    Cells(1, 1).  Select    ActiveSheet.Outline.ShowLevels RowLevels:=1    Application.ScreenUpdating =   True    End   Sub   
 
Прикольно! Только, если много раз нажимать на кнопку, добавляться начинаю группировки. Учитывая, что начальство мало что понимает в экселе, они будут жать эту кнопку. Можно как-то исправить?
 
Цитата
JERY написал:
Можно как-то исправить
Конечно, удалите кнопку и запускайте макрос как описано ТУТ
Изменено: Msi2102 - 04.08.2022 10:34:18
 
Цитата
написал:
Цитата
JERY написал:
Можно как-то исправить
Конечно, удалите кнопку и запускайте макрос как описано  ТУТ
Понял, поковыряюсь...
 
Цитата
написал:
Если преобразовать данные в нормальный вид и построить по ним штатную сводную
Подскажите что за "штатная сводная" ? Умная таблица или именно Вставка, Сводная таблица?
 
Или почитайте ЭТУ статью. Запишите макрос в личную книгу макросов и пользоваться будете только Вы, а начальству готовый результат.
Или добавьте условие, что если есть группировка, то ничего не делать
 
Так выглядит штатная сводная по нормальной таблице из ваших данных
Поля можно сворачивать и разворачивать (аналог группировки), а также можно свернуть/развернуть все поля
Изменено: Jack Famous - 04.08.2022 10:46:22
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
JERY, Вы не находите, что ответ на ваш вопрос находится в вашем вопросе?  :D
 
Запишите макрос так:
Код
Sub Groupr()
Dim cl As Range, rng As Range, lr As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 1).End(xlUp).Row
For Each cl In Range("A6:A" & lr)
    If cl.Rows.OutlineLevel > 1 Then Exit Sub
    If cl.DisplayFormat.Interior.Color = 16777215 Then
        If rng Is Nothing Then Set rng = cl.Rows Else Set rng = Union(rng, cl.Rows)
    Else
        If Not rng Is Nothing Then rng.Rows.Group: Set rng = Nothing
    End If
Next
If Not rng Is Nothing Then rng.Rows.Group
Cells(1, 1).Select
ActiveSheet.Outline.ShowLevels RowLevels:=1
Application.ScreenUpdating = True
End Sub

или замените
Код
If cl.Rows.OutlineLevel > 1 Then Exit Sub

на
Код
If cl.Rows.OutlineLevel > 1 Then Range("A6:A" & lr).Rows.Ungroup

и тогда будет перегруппировка если при наличии группировки, что-то закрасили
 
Цитата
написал:
JERY, Вы не находите, что ответ на ваш вопрос находится в вашем вопросе?  
НЕТ.
 
Цитата
написал:
и тогда будет перегруппировка если при наличии группировки, что-то закрасили
Большое спасибо!
 
Цитата
написал:
Поля можно сворачивать и разворачивать (аналог группировки), а также можно свернуть/развернуть все поля
Ну, да, точно! В принципе в Сводной можно кучу всего. Просто я же говорю, начальство не догадается, что нужно правой кнопкой мыши щелкнуть и нажать "свернуть все поля". Все равно спасибо за просвещение. Все гениальное просто!
 
Цитата
JERY: начальство не догадается, что нужно правой кнопкой мыши щелкнуть и нажать "свернуть все поля"
до кнопок группировки доросли, значит и с этим справятся. К тому же можно просто кнопки + и - сделать для разворачивания/сворачивания. Есть даже вариант без макроса.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
JERY написал:
Просто я же говорю, начальство не догадается,
Что ж Вы как о своем начальстве  :(
Страницы: 1
Наверх