Страницы: 1
RSS
Группировка строк по ориентирам
 
добрый день. в файле есть таблица. в столбце 1 есть значения(ориентиры). надо сгруппировать строки после ориентира и до следующего ориентира. если нет ориентира, то группировать до конца таблицы. на листе как надо - ожидаемый результат. по моему, такое автоматом можно сделать только макросом. не могли бы написать такой макрос
 
artyrH, Пора осваивать уже :-) .
Записать макрорекордером группировку блока
очистить от мусора
Selection заменить на диапазон строк.
вложить это в цикл, а цикл сделать или с быстрым поиском следующего непустого через end(xldown) Или перебором , но все в пределах диапазона таблички.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ написал:
Пора осваивать
хорошо. я только за
из циклов я знаком только с for-next. совместно с макрорекордером получил следующий макрос. теперь как изменить? вместо 4 высчитать количество ориентиров. вместо Rows("8:18") только строки между ориентиром и следующим ориентиром.
Код
Sub макрос1()

For i = 1 To 4
    Rows("8:18").Select
    Selection.Rows.Group
  '  Rows("20:24").Select
  '  Selection.Rows.Group
  '  Rows("26:36").Select
  '  Selection.Rows.Group
  '  Rows("38:40").Select
  '  Selection.Rows.Group
Next i

End Sub
 
если между ориентирами ячейки пустые, то можно как-то так
Код
Sub GroupRows()
    Dim ar As Range
    For Each ar In [Таблица2].ListObject.ListColumns(1).Range.SpecialCells(4).Areas
        ar.Rows.Group
    Next
End Sub
 
Код
Sub RowsGroup()
  With ActiveSheet.Outline
    .AutomaticStyles = False: .SummaryRow = xlAbove: .SummaryColumn = xlLeft
  End With
  Dim rg1 As Range, rg2 As Range:  Set rg1 = Cells(1).End(xlDown)
  Do While True
    If IsEmpty(rg1.Offset(1)) Then
      Set rg2 = rg1.End(xlDown)
      With Range(rg1.Offset(1), IIf(IsEmpty(rg2), rg2, rg2.Offset(-1))).EntireRow
        .Group: .Hidden = True: If IsEmpty(rg2) Then Exit Sub Else Set rg1 = rg2
      End With
    Else
      Set rg1 = rg1.Offset(1)
    End If
  Loop
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Пока разбирался как группировку снять, уже опередили...
Код
Option Explicit

Sub myGr()
Dim rngOld As Range
Dim rngNew As Range
    
    Rows.Hidden = False
    On Error Resume Next
    Rows.Ungroup
    On Error GoTo 0
    
    Set rngOld = ActiveSheet.Range("A7")
    Set rngNew = rngOld.End(xlDown)

    Do While rngNew.Row < Cells.SpecialCells(xlLastCell).Row
        ActiveSheet.Range(rngOld.Offset(1).Row & ":" & rngNew.Offset(-1).Row).Rows.Group
        
        Set rngOld = rngNew
        Set rngNew = rngOld.End(xlDown)
    Loop
End Sub
Я не волшебник, я только учусь.
 
спасибо всем за решения. что то более менее понятно, что то нет. сам все равно так построить не смогу
Андрей Лящук,  можно узнать за что отвечает цифра 4?
Ігор Гончаренко, что выполняет вот эта часть кода?
Код
  With ActiveSheet.Outline
    .AutomaticStyles = False: .SummaryRow = xlAbove: .SummaryColumn = xlLeft
  End With
 
Собрались демоны. Нет чтоб по простому без выпендрежа написать чтоб ТС и результат получил и понял как.  :D

artyrH,  с определенного уровня docs.microsoft.com незаменим
https://docs.microsoft.com/en-us/office/vba/api/excel.range.specialcells
https://docs.microsoft.com/en-us/office/vba/api/excel.xlcelltype
xlCellTypeBlanks 4  Empty cells . то есть из указанного диапазона берутся только пустые.
При этом я в угоду сохранения символов не заменяю константы на их значения, ну если это не используется в другом приложении, а если используется то лучше определить константу. Так становится код понятнее.
По вопросам из тем форума, личку не читаю.
 
строки 8:18 относятся к признаку 1 или 3? (в моем коде к 1)
строки 20:24 относятся к 3 или к g (у меня к 3)

Андрей Лящук написал лучший код:
используйте:
Код
Sub GroupRows()
  Dim ar As Range
  With ActiveSheet.Outline    .
    AutomaticStyles = False: .SummaryRow = xlAbove: .SummaryColumn = xlLeft
  End With
  For Each ar In [Таблица2].ListObject.ListColumns(1).Range.SpecialCells(4).Areas
    ar.Rows.Group: ar.Rows.Hidden = True
  Next
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, ok. спасибо. позже попробую сам собрать по варианту от БМВ. что нужно добавить в последний предложенный код, чтоб не выходила ошибка как на скрине?  
 
Код
Sub GroupRows()
  Dim ar As Range
  If WorksheetFunction.CountBlank([Таблица2].Columns(1)) = 0 Then Exit Sub
  With ActiveSheet.Outline
    .AutomaticStyles = False: .SummaryRow = xlAbove: .SummaryColumn = xlLeft
  End With
  For Each ar In [Таблица2].Columns(1).SpecialCells(4).Areas
    ar.Rows.Group: ar.Rows.Hidden = True
  Next
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, спасибо. все работает
Страницы: 1
Наверх