Макрос - разделить лист по уровню группировки

@Julia131 · Регистрация: 12.02.2018

Студворк — интернет-сервис помощи студентам

Добрый день! Прошу помощи в решении, так сказать, проблемы. Выгружаю отчет с 1С, при этом есть сгруппированные строки и шапка таблицы.
Таблицу необходимо разделить на несколько книг. Принцип деления- шапка ( 5 строк)+ сгруппированные ячейки. Сначала необходимо поделить по первому уровню группировки( т.е все строки которые в этой группировке), затем по второму.
К сожалению, о таких макросах не нашла ничего. Заранее благодарна!

@Julia131 · 13.02.2018, 10:15 **[ТС]**

Во вложении Пример.xlsx. Первый лист - Исходные данные (как есть). Остальные листы это листы которые необходимо получить (лучше, конечно, в разных книгах). Кто то сможет помочь?

@Julia131 · 15.02.2018, 10:45 **[ТС]**

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Public Sub Макрос1()
    
    'Создаем новую книгу
    Dim wkbNewWorkbook As Workbook
    Set wkbNewWorkbook = Application.Workbooks.Add
    
    'Сохраняем в каталоге исходного файла
    wkbNewWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & wkbNewWorkbook.Name, _
        FileFormat:=xlOpenXMLWorkbook   '.xlsx
        'FileFormat:= xlExcel8          '.xls
    
    'Копируем диапазон в новую книгу на первый лист
    ThisWorkbook.ActiveSheet.Range("A7:Q10").Copy _
        Destination:=wkbNewWorkbook.Worksheets.Item(1).Range("A1")
    ThisWorkbook.ActiveSheet.Range("A11:Q322").Copy _
        Destination:=wkbNewWorkbook.Worksheets.Item(1).Range("A5")
    Columns("A:Q").Select
    Range("A500").Activate
    Selection.ColumnWidth = 11
   Set wkbNewWorkbook = Nothing
    
End Sub

Получилось собрать вот такой макрос, (указываю необходимое кол-во строк, столбцов и копирую в новую книгу).

При этом теряется группировка строк. Можно ли ее сохранить или дописать группировку по цвету заливки ячейки. при этом цвета могут повторяться. Заранее благодарна.

@zewsua · 15.02.2018, 16:04

Julia131, смотрю

Добавлено через 8 минут

Сообщение от Julia131

ThisWorkbook.ActiveSheet.Range("A7:Q10") .Copy _
Destination:=wkbNewWorkbook.Worksheets.I tem(1).Range("A1")
ThisWorkbook.ActiveSheet.Range("A11:Q322 ").Copy _

если желаете сохранить группировку то укажите вместо Range - Rows

Visual Basic
1
2
3
4
ThisWorkbook.ActiveSheet.Rows("7:11").Copy _
Destination:=wkbNewWorkbook.Worksheets.Item(1).Range("A1")
ThisWorkbook.ActiveSheet.Rows("11:322").Copy _
Destination:=wkbNewWorkbook.Worksheets.Item(1).Range("A5")

В остальном немного не понял что нужно сделать, сейчас постараюсь разобраться с Вашим файлом

Добавлено через 11 минут
Julia131, количество людей в группах может быть всегда разное?

@Julia131 · 16.02.2018, 09:42 **[ТС]**

zewsua, спасибо за подсказку, сама пробовала но меняла на строки только в шапке и удивлялась, почему не получилось, поменяла там и там- копирует указанный диапазон и сохраняет группировки.

Да, количество людей в группах может быть разное.

Добавлено через 16 часов 53 минуты

Сообщение от zewsua

Julia131, количество людей в группах может быть всегда разное?

пока нашла выход это указывать кол-во строк, группировки сохраняются. Это не так быстро, так как строк может быть разное кол-во и группировок больше чем в примере, но это уже на много быстрее чем делать руками.
Спасибо за подсказку по поводу строк!

Можно ли поделить по уровням группировки- вопрос остается открытым.

@Step_UA · 16.02.2018, 13:43

Исходные данные в активном листе ... без каких-либо проверок на существование листов/повторов и пр.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub gr2sheet()
  Const begData = 6 ' номер первой строки с данными
  Dim Title As Range, sh As Worksheet
  Dim endRow&(1 To 7), oldLevel&, curRow&, curLevel&
    Set sh = ActiveSheet ' лист с исходными данными - активный
    Set Title = sh.Rows(1).Resize(begData - 1)
    Application.ScreenUpdating = False
    sh.Outline.ShowLevels 8
    oldLevel = 1
    For curRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row To begData Step -1
        curLevel = sh.Rows(curRow).OutlineLevel
        If curLevel > oldLevel Then
            For oldLevel = oldLevel To curLevel - 1
                endRow(oldLevel) = curRow
            Next
        ElseIf curLevel < oldLevel Then
            Sheets.Add(After:=sh).Outline.SummaryRow = xlSummaryAbove
            Title.Copy
            Cells(1).PasteSpecial Paste:=xlPasteColumnWidths
            ActiveSheet.Paste
            sh.Rows(curRow & ":" & endRow(curLevel)).Copy Cells(begData, 1)
            ActiveSheet.Name = Cells(begData, 1).Value
            ActiveSheet.UsedRange.EntireRow.Ungroup ' *
            oldLevel = curLevel
        End If
    Next
    ' sh.Outline.ShowLevels 1 ' *
    sh.Select  ' *
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

@Julia131 · 16.02.2018, 16:08 **[ТС]**

Спасибо! То что надо! Может немного изменю, но это уже мелочи!

@Julia131 · 20.02.2018, 10:44 **[ТС]**

Сообщение от Step_UA

без каких-либо проверок на существование листов/повторов и пр.

К сожалению, нужна еще помощь. Так и не поняла как мне указать чтобы макрос не делил по 3 и 4 уровню. Т.е. только по 1 и 2 ( самые большие). ( могут быть повторяющиеся значения, макрос останавливается, да и не нужна разбивка по этим уровням)

Помогите, пожалуйста =)

Заранее очень и очень благодарна!!!

@Step_UA · 20.02.2018, 19:53

Сообщение от Julia131

Так и не поняла как мне указать чтобы макрос не делил по 3 и 4 уровню. Т.е. только по 1 и 2

В строках 17-23 происходит копирование - проверяйте текущий уровень, если он больше максимально требуемого, то не выполняйте эти строки ...

Сообщение от Julia131

могут быть повторяющиеся значения

предлагаете угадать что в данном случае делать?

Не по теме:

Тема была интересна в плане определения диаппазонов групп, далее уже не интересно

@Julia131 · 22.02.2018, 10:01 **[ТС]**

Сообщение от Step_UA

В строках 17-23 происходит копирование - проверяйте текущий уровень, если он больше максимально требуемого, то не выполняйте эти строки

Мне как раз и нужно деление по самым большим уровням. Тогда и исчезает вопрос по поводу повторяющихся. Сейчас как я поняла от разделяет сначала по самым маленьким группам, затем больше. Т.е. сначала по 4, потом по 3 и т.д. А мне нужно только по 1 и 2.
В любом случае спасибо за помощь!!!
Буду думать как это сделать, пока не поняла.

Новые блоги и статьи Все статьи Все блоги /
Установка Qt Creator для C и C++: ставим среду, CMake и MinGW без фреймворка Qt 8Observer8 05.04.2026 Среду разработки Qt Creator можно установить без фреймворка Qt. Есть отдельный репозиторий для этой среды: https:/ / github. com/ qt-creator/ qt-creator, где можно скачать установщик, на вкладке Releases:. . .	AkelPad-скрипты, структуры, и немного лирики.. testuser2 05.04.2026 Такая программа, как AkelPad существует уже давно, и также давно существуют скрипты под нее. Тем не менее, прога живет, периодически что-то не спеша дополняется, улучшается. Что меня в первую очередь. . .	Отображение реквизитов в документе по условию и контроль их заполнения Maks 04.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "ПланированиеСпецтехники", разработанного в конфигурации КА2. Данный документ берёт данные из другого нетипового документа. . .	Фото всей Земли с борта корабля Orion миссии Artemis II kumehtar 04.04.2026 Это первое подобное фото сделанное человеком за 50 лет. Снимок называют новым вариантом легендарной фотографии «The Blue Marble» 1972 года, сделанной с борта корабля «Аполлон-17». Новое фото. . .
Вывод диалогового окна перед закрытием, если документ не проведён Maks 04.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "СписаниеМатериалов", разработанного в конфигурации КА2. Задача: реализовать программный контроль на предмет проведения документа. . .	Программный контроль заполнения реквизитов табличной части документа Maks 02.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "СписаниеМатериалов", разработанного в конфигурации КА2. Задача: 1. Реализовать контроль заполнения реквизита. . .	wmic не является внутренней или внешней командой Maks 02.04.2026 Решение: DISM / Online / Add-Capability / CapabilityName:WMIC~~~~ Отсюда: https:/ / winitpro. ru/ index. php/ 2025/ 02/ 14/ komanda-wmic-ne-naydena/	Программная установка даты и запрет ее изменения Maks 02.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "СписаниеМатериалов", разработанного в конфигурации КА2. Задача: при создании документов установить период списания автоматически. . .

@Julia131 0 / 0 / 0 Регистрация: 12.02.2018 Сообщений: 7

	Макрос - разделить лист по уровню группировки 12.02.2018, 11:20. Показов 4654. Ответов 9 Метки макросы (Все метки) Добрый день! Прошу помощи в решении, так сказать, проблемы. Выгружаю отчет с 1С, при этом есть сгруппированные строки и шапка таблицы. Таблицу необходимо разделить на несколько книг. Принцип деления- шапка ( 5 строк)+ сгруппированные ячейки. Сначала необходимо поделить по первому уровню группировки( т.е все строки которые в этой группировке), затем по второму. К сожалению, о таких макросах не нашла ничего. Заранее благодарна! 0

@Julia131 0 / 0 / 0 Регистрация: 12.02.2018 Сообщений: 7
	13.02.2018, 10:15 [ТС]
	Во вложении Пример.xlsx. Первый лист - Исходные данные (как есть). Остальные листы это листы которые необходимо получить (лучше, конечно, в разных книгах). Кто то сможет помочь? 0

@Julia131 0 / 0 / 0 Регистрация: 12.02.2018 Сообщений: 7
	16.02.2018, 16:08 [ТС]
	Спасибо! То что надо! Может немного изменю, но это уже мелочи! 0

Макрос - разделить лист по уровню группировки

Решение