Страницы: 1
RSS
Трехуровневая / многоуровневая группировка данных c помощью VBA
 
Доброго времени суток.
Помогите пожалуйста с группировкой данных. Нужен макрос который сгруппирует данные, как во вложенном листе.
Спасибо всем кто откликнется.
 
Попробуйте так..
Код
Sub Овал1_Щелчок()
    Dim r As Range, c As Range
    Application.ScreenUpdating = 0
    Set r = Sheets(1).Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    r.ClearOutline
    For Each c In r
        If Not (Cells(c.Row, 1) = "" And Cells(c.Row, 2) <> "" And Cells(c.Row, 3) = "") Then
            c.EntireRow.Group
        End If
    Next
End Sub
 
Маугли, среднее условие, вроде, избыточное:  And Cells(c.Row, 2) <> ""
Код
If Not (Cells(c.Row, 1) = "" And Cells(c.Row, 3) = "") Then
    c.EntireRow.Group
End If

' Или даже так (контроль группы по пустой ячейке в первом столбце):
If Cells(c.Row, 1) <> "" Then
    c.EntireRow.Group
End If
Изменено: eeigor - 10.05.2019 07:36:25
 
Маугли , спасибо, за код. Он работает. Но есть необходимость вот в этом месте. Три уровня и на листе "2" - это таблица.
Фаил прикреплен.

Цитата
eeigor написал:  среднее условие, вроде, избыточное:  And Cells(c.Row, 2) <> ""
Пытаюсь, так же понять... Ваш коментарий. Всмыле разобраться, как можно сгруппировать данные.

Коллеги, нужна ваша поддержка.
Спасибо.
Изменено: Alex D - 10.05.2019 11:06:55
 
Понял так..
Код
Sub Овал1_Щелчок()
    Dim r As Range, c As Range
    Application.ScreenUpdating = 0
    ActiveSheet.ListObjects("Table1").Unlist
    Set r = Sheets(2).Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
    r.ClearOutline
    For Each c In r
        If Not (Cells(c.Row, 1) = "" And Cells(c.Row, 2) <> "" And Cells(c.Row, 3) = "") Then
            c.EntireRow.Group
        End If
    Next
    r.Resize(r.Rows.Count).EntireRow.Group
    ActiveSheet.ListObjects.Add(xlSrcRange, r.CurrentRegion, , xlYes).Name = "Table1"
End Sub
 
Код
Sub apply_groups()
Application.ScreenUpdating = 0

Dim c As Integer
 Sheets("Input SAP").Activate
 ActiveSheet.Outline.ShowLevels RowLevels:=3 ' level of rows
    c = Range("A1").CurrentRegion.Rows.Count
    Range("B2:B" & (c - 2)).Rows.Group
    Range("B2:B" & (c - 2)).Rows.Group
    For i = 2 To c - 2
        If Range("A" & i) = "" Then
            Range("A" & i).Rows.Ungroup
        End If
    Next i
Application.ScreenUpdating = 1

End Sub

Вот такое получилось :)

@Маугли большое спасибо!
Страницы: 1
Наверх