Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/создание листов по уровням таблицы с суммированием - Мир MS Excel

  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
создание листов по уровням таблицы с суммированием
smugi Дата: Понедельник, 18.08.2025, 17:19 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Здравствуйте, Макрос создание листов по уровням таблицы (в файле называется разгруппировка) из темы Создание листов по уровням таблицы. Мне нужна помощь в модернизации этого макроса - добавить функционал для каждого созданного листа: удаление дубликатов, суммирования по значению. Сделала отдельно макрос (называется Остальное) через запись. Но у меня не получается объединить так, чтоб добавленный функционал работал сразу для каждого листа. А вся соль созданного макроса в том, что с объемом строк более 20.000, он зависает. Поэтому пришлось формулы суммирования только в первых ячейках делать, а потом протягивать ручками.
К сообщению приложен файл: 1845641.xlsm (31.1 Kb)
 
Ответить
СообщениеЗдравствуйте, Макрос создание листов по уровням таблицы (в файле называется разгруппировка) из темы Создание листов по уровням таблицы. Мне нужна помощь в модернизации этого макроса - добавить функционал для каждого созданного листа: удаление дубликатов, суммирования по значению. Сделала отдельно макрос (называется Остальное) через запись. Но у меня не получается объединить так, чтоб добавленный функционал работал сразу для каждого листа. А вся соль созданного макроса в том, что с объемом строк более 20.000, он зависает. Поэтому пришлось формулы суммирования только в первых ячейках делать, а потом протягивать ручками.

Автор - smugi
Дата добавления - 18.08.2025 в 17:19
msi2102 Дата: Вторник, 19.08.2025, 09:59 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 446
Репутация: 133 ±
Замечаний: 0% ±

Excel 2019
Пробуйте
[vba]
Код
Sub Разгруппировка()
    Dim rn As Range, rn_ob As Range, lv As String, sd As Object, lst As Object, inn As Object, sh As Worksheet, wsh As Worksheet, n As Integer, m As Integer, y, y1
    Set sd = CreateObject("Scripting.Dictionary")
    Set inn = CreateObject("Scripting.Dictionary")
    Set lst = CreateObject("Scripting.Dictionary")
    Set wsh = ActiveSheet
    Set rn_ob = wsh.UsedRange.Rows
    For Each sh In ActiveWorkbook.Worksheets
        lst.Add sh.Name, sh.Name
    Next
    For Each rn In rn_ob
        If rn.Rows.OutlineLevel = 2 Then
            lv = rn.Value2(1, 1)
            If Not sd.Exists(lv) Then
                sd.Add lv, rn
                Set inn(lv) = CreateObject("Scripting.Dictionary")
            Else
                Set sd(lv) = Application.Union(sd(lv), rn)
            End If
        ElseIf rn.Rows.OutlineLevel > 2 Then
            Set sd(lv) = Application.Union(sd(lv), rn)
            If Not inn(lv).Exists(rn.Value2(1, 1)) And rn.Value2(1, 1) <> "" Then inn(lv).Add rn.Value2(1, 1), rn.Value2(1, 1)
        End If
    Next
    For Each y In sd
        lv = y
        If lst.Exists(lv) Then
            n = 1
            Do
                lv = y
                lv = lv & n
                n = n + 1
            Loop Until Not lst.Exists(lv)
        End If
        Sheets.Add.Name = lv
        sd(y).Copy Destination:=Worksheets(lv).Range("D1")
        Dim arr
        ReDim arr(1 To inn(y).Count, 1 To 3)
        m = 1
        For Each y1 In inn(y)
            arr(m, 1) = CStr(y1)
            If Left(y1, 3) <> "ИИН" Then ' обратите внимание у Вас вместо ИНН стоит ИИН
                arr(m, 2) = "=СУММЕСЛИ(D:D;A" & m + 1 & ";P:P)"
                arr(m, 3) = "=СУММЕСЛИ(D:D;A" & m + 1 & ";R:R)"
            End If
            m = m + 1
        Next
        Worksheets(lv).Columns("A:A").ColumnWidth = 17
        Worksheets(lv).Columns("A:A").NumberFormat = "@"
        Worksheets(lv).Range("A2").Resize(UBound(arr), 3).FormulaLocal = arr
    Next
End Sub
[/vba]
К сообщению приложен файл: 1845641_1.xlsm (27.7 Kb)
 
Ответить
СообщениеПробуйте
[vba]
Код
Sub Разгруппировка()
    Dim rn As Range, rn_ob As Range, lv As String, sd As Object, lst As Object, inn As Object, sh As Worksheet, wsh As Worksheet, n As Integer, m As Integer, y, y1
    Set sd = CreateObject("Scripting.Dictionary")
    Set inn = CreateObject("Scripting.Dictionary")
    Set lst = CreateObject("Scripting.Dictionary")
    Set wsh = ActiveSheet
    Set rn_ob = wsh.UsedRange.Rows
    For Each sh In ActiveWorkbook.Worksheets
        lst.Add sh.Name, sh.Name
    Next
    For Each rn In rn_ob
        If rn.Rows.OutlineLevel = 2 Then
            lv = rn.Value2(1, 1)
            If Not sd.Exists(lv) Then
                sd.Add lv, rn
                Set inn(lv) = CreateObject("Scripting.Dictionary")
            Else
                Set sd(lv) = Application.Union(sd(lv), rn)
            End If
        ElseIf rn.Rows.OutlineLevel > 2 Then
            Set sd(lv) = Application.Union(sd(lv), rn)
            If Not inn(lv).Exists(rn.Value2(1, 1)) And rn.Value2(1, 1) <> "" Then inn(lv).Add rn.Value2(1, 1), rn.Value2(1, 1)
        End If
    Next
    For Each y In sd
        lv = y
        If lst.Exists(lv) Then
            n = 1
            Do
                lv = y
                lv = lv & n
                n = n + 1
            Loop Until Not lst.Exists(lv)
        End If
        Sheets.Add.Name = lv
        sd(y).Copy Destination:=Worksheets(lv).Range("D1")
        Dim arr
        ReDim arr(1 To inn(y).Count, 1 To 3)
        m = 1
        For Each y1 In inn(y)
            arr(m, 1) = CStr(y1)
            If Left(y1, 3) <> "ИИН" Then ' обратите внимание у Вас вместо ИНН стоит ИИН
                arr(m, 2) = "=СУММЕСЛИ(D:D;A" & m + 1 & ";P:P)"
                arr(m, 3) = "=СУММЕСЛИ(D:D;A" & m + 1 & ";R:R)"
            End If
            m = m + 1
        Next
        Worksheets(lv).Columns("A:A").ColumnWidth = 17
        Worksheets(lv).Columns("A:A").NumberFormat = "@"
        Worksheets(lv).Range("A2").Resize(UBound(arr), 3).FormulaLocal = arr
    Next
End Sub
[/vba]

Автор - msi2102
Дата добавления - 19.08.2025 в 09:59
smugi Дата: Вторник, 19.08.2025, 12:09 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

msi2102, ОТЛИЧНО работает и не зависает. Вы гений hands Я забыла написать про макрос, который находился внутри макроса ОСТАЛЬНОЕ. у меня еще должны были удалятся строки где есть слова "отклонен" и "аннулирован". Чтоб не создавать тему, его можно также добавить в ВАШ макрос?
 
Ответить
Сообщениеmsi2102, ОТЛИЧНО работает и не зависает. Вы гений hands Я забыла написать про макрос, который находился внутри макроса ОСТАЛЬНОЕ. у меня еще должны были удалятся строки где есть слова "отклонен" и "аннулирован". Чтоб не создавать тему, его можно также добавить в ВАШ макрос?

Автор - smugi
Дата добавления - 19.08.2025 в 12:09
smugi Дата: Вторник, 19.08.2025, 12:18 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

В макросе написано "...' обратите внимание у Вас вместо ИНН стоит ИИН". ИИН это правильно.
 
Ответить
СообщениеВ макросе написано "...' обратите внимание у Вас вместо ИНН стоит ИИН". ИИН это правильно.

Автор - smugi
Дата добавления - 19.08.2025 в 12:18
msi2102 Дата: Вторник, 19.08.2025, 12:18 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 446
Репутация: 133 ±
Замечаний: 0% ±

Excel 2019
где есть слова "отклонен" и "аннулирован"


Где в Вашем примере есть эти слова
 
Ответить
Сообщение
где есть слова "отклонен" и "аннулирован"


Где в Вашем примере есть эти слова

Автор - msi2102
Дата добавления - 19.08.2025 в 12:18
smugi Дата: Вторник, 19.08.2025, 12:45 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

забыла добавить
К сообщению приложен файл: 8482386.xlsm (31.0 Kb)
 
Ответить
Сообщениезабыла добавить

Автор - smugi
Дата добавления - 19.08.2025 в 12:45
msi2102 Дата: Вторник, 19.08.2025, 13:30 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 446
Репутация: 133 ±
Замечаний: 0% ±

Excel 2019
Вот два варианта, в первом макрос будет собирать данные без строк с "отклонен" и "аннулирован", но при таком раскладе могут возникнуть проблемы с Application.Union (этот метод имеет определенные ограничения) и если будет выдавать ошибку, то нужно переписывать макрос, а этого уже не хочется. Поэтому написал второй вариант, в нем копируется полностью как и было, а в расчете суммы изменил формулу на =СУММЕСЛИМН(). И ещё как вариант, можно установить фильтр в исходных данных и отфильтровать по строкам которые содержат слова "отклонен" и "аннулирован" и удалить их, а после этого запускать макрос.
Вы изначально когда пишите хотелки старайтесь обговаривать все условия.
К сообщению приложен файл: 1726369.xlsm (24.5 Kb)
 
Ответить
СообщениеВот два варианта, в первом макрос будет собирать данные без строк с "отклонен" и "аннулирован", но при таком раскладе могут возникнуть проблемы с Application.Union (этот метод имеет определенные ограничения) и если будет выдавать ошибку, то нужно переписывать макрос, а этого уже не хочется. Поэтому написал второй вариант, в нем копируется полностью как и было, а в расчете суммы изменил формулу на =СУММЕСЛИМН(). И ещё как вариант, можно установить фильтр в исходных данных и отфильтровать по строкам которые содержат слова "отклонен" и "аннулирован" и удалить их, а после этого запускать макрос.
Вы изначально когда пишите хотелки старайтесь обговаривать все условия.

Автор - msi2102
Дата добавления - 19.08.2025 в 13:30
msi2102 Дата: Вторник, 19.08.2025, 13:32 | Сообщение № 8
Группа: Проверенные
Ранг: Обитатель
Сообщений: 446
Репутация: 133 ±
Замечаний: 0% ±

Excel 2019
Вариант 2, приходится ещё одним сообщением, так как превысил количество символов

 
Ответить
СообщениеВариант 2, приходится ещё одним сообщением, так как превысил количество символов


Автор - msi2102
Дата добавления - 19.08.2025 в 13:32
smugi Дата: Вторник, 19.08.2025, 14:58 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Первый вариант работает без ошибок. Второй вариант интересный, почему-то раньше в голову не приходило исключать строки со словами "отклонен" и "аннулирован" из общей суммы. Спасибо ОГРОМНОЕ.
 
Ответить
СообщениеПервый вариант работает без ошибок. Второй вариант интересный, почему-то раньше в голову не приходило исключать строки со словами "отклонен" и "аннулирован" из общей суммы. Спасибо ОГРОМНОЕ.

Автор - smugi
Дата добавления - 19.08.2025 в 14:58
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!