Страницы: 1
RSS
Группировка строк по условию. Выполнение цикла до конца документа
 
Доброго времени суток.
Написал макрос для группировки строк по условию: отсутствия цвета(от условного форматирования).
Код
Sub Sort()
' Сочетание клавиш: Ctrl+M(ь)

Application.ScreenUpdating = False
Dim a, b As Variant
b = 1

    Do Until IsEmpty(Cells(b, 1))
    a = Cells(b, 1).DisplayFormat.Interior.Color
    If a = "16777215" Then
    Rows(b).Select
    Selection.Rows.Group
    b = b + 1
    Else
    b = b + 1
    End If
    Loop
    
Cells(1, 1).Select
ActiveSheet.Outline.ShowLevels RowLevels:=1
Application.ScreenUpdating = True
End Sub
Но столкнулся с проблемой: столбцы в документе могут идти друг под другом(см. файл пример) и соответственно, макрос прерывается при пустой строке.
Кол-во строк между столбцами(выделено желтым) могут быть разными.

Пробывал добавить:
Код
Selection.End(xlDown).Select
И повторить цикл, однако не работает.

Есть ли какой-либо путь, без перебора всего рабочего листа?
Буду благодарен за любые советы и рекомендации.  
 
Код
Sub Sort()
    Application.ScreenUpdating = False
    Dim a, b As Variant
    For b = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        a = Cells(b, 1).DisplayFormat.Interior.Color
        If a = "16777215" Then
            Rows(b).Select
            Selection.Rows.Group
        End If
    Next
    Cells(1, 1).Select
    ActiveSheet.Outline.ShowLevels RowLevels:=1
    Application.ScreenUpdating = True
End Sub
 
Андрей_26, Спасибо!
 
В вашем случае можно использовать цикл или по диапазону
intersect(columns(1),activesheet.usedrange)
или
искать последнюю заполненную ячейку Cells(rows.count,1).end(xlup)  и далее организовать цикл до нее. ( собственно это уже выше предложено)
хотя я б записал иначе
Код
For Each Cell In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
If Cell.DisplayFormat.Interior.Color = "16777215" Then
Cell.EntireRow.Group
End If
Next

хотя по каждой строке группировать не очень эффективно.
 
P.S. Dim a, b As Variant -или As Variant лишнее или нужно типы нормальные использовать.
Изменено: БМВ - 19.08.2021 08:44:40
По вопросам из тем форума, личку не читаю.
 
БМВ, Спасибо за советы, приму на вооружение.  
 
Так будет побыстрее
Код
Sub Sort1()

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("A2: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 - 19.08.2021 09:00:01
Страницы: 1
Наверх