Здравствуйте, Макрос создание листов по уровням таблицы (в файле называется разгруппировка) из темы Создание листов по уровням таблицы. Мне нужна помощь в модернизации этого макроса - добавить функционал для каждого созданного листа: удаление дубликатов, суммирования по значению. Сделала отдельно макрос (называется Остальное) через запись. Но у меня не получается объединить так, чтоб добавленный функционал работал сразу для каждого листа. А вся соль созданного макроса в том, что с объемом строк более 20.000, он зависает. Поэтому пришлось формулы суммирования только в первых ячейках делать, а потом протягивать ручками.
Здравствуйте, Макрос создание листов по уровням таблицы (в файле называется разгруппировка) из темы Создание листов по уровням таблицы. Мне нужна помощь в модернизации этого макроса - добавить функционал для каждого созданного листа: удаление дубликатов, суммирования по значению. Сделала отдельно макрос (называется Остальное) через запись. Но у меня не получается объединить так, чтоб добавленный функционал работал сразу для каждого листа. А вся соль созданного макроса в том, что с объемом строк более 20.000, он зависает. Поэтому пришлось формулы суммирования только в первых ячейках делать, а потом протягивать ручками.smugi
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]
Пробуйте [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
msi2102, ОТЛИЧНО работает и не зависает. Вы гений Я забыла написать про макрос, который находился внутри макроса ОСТАЛЬНОЕ. у меня еще должны были удалятся строки где есть слова "отклонен" и "аннулирован". Чтоб не создавать тему, его можно также добавить в ВАШ макрос?
msi2102, ОТЛИЧНО работает и не зависает. Вы гений Я забыла написать про макрос, который находился внутри макроса ОСТАЛЬНОЕ. у меня еще должны были удалятся строки где есть слова "отклонен" и "аннулирован". Чтоб не создавать тему, его можно также добавить в ВАШ макрос?smugi
Вот два варианта, в первом макрос будет собирать данные без строк с "отклонен" и "аннулирован", но при таком раскладе могут возникнуть проблемы с Application.Union (этот метод имеет определенные ограничения) и если будет выдавать ошибку, то нужно переписывать макрос, а этого уже не хочется. Поэтому написал второй вариант, в нем копируется полностью как и было, а в расчете суммы изменил формулу на =СУММЕСЛИМН(). И ещё как вариант, можно установить фильтр в исходных данных и отфильтровать по строкам которые содержат слова "отклонен" и "аннулирован" и удалить их, а после этого запускать макрос. Вы изначально когда пишите хотелки старайтесь обговаривать все условия.
[vba]
Код
Sub Разгруппировка_v1() 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 If rn.Value2(1, 5) <> "отклонен" And rn.Value2(1, 5) <> "аннулирован" 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 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]
Вот два варианта, в первом макрос будет собирать данные без строк с "отклонен" и "аннулирован", но при таком раскладе могут возникнуть проблемы с Application.Union (этот метод имеет определенные ограничения) и если будет выдавать ошибку, то нужно переписывать макрос, а этого уже не хочется. Поэтому написал второй вариант, в нем копируется полностью как и было, а в расчете суммы изменил формулу на =СУММЕСЛИМН(). И ещё как вариант, можно установить фильтр в исходных данных и отфильтровать по строкам которые содержат слова "отклонен" и "аннулирован" и удалить их, а после этого запускать макрос. Вы изначально когда пишите хотелки старайтесь обговаривать все условия.
[vba]
Код
Sub Разгруппировка_v1() 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 If rn.Value2(1, 5) <> "отклонен" And rn.Value2(1, 5) <> "аннулирован" 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 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
Вариант 2, приходится ещё одним сообщением, так как превысил количество символов
[vba]
Код
Sub Разгруппировка_v2() 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) = "=СУММЕСЛИМН(P:P;D:D;A" & m + 1 & ";H:H;""<>аннулирован"";H:H;""<>отклонен"")" arr(m, 3) = "=СУММЕСЛИМН(R:R;D:D;A" & m + 1 & ";H:H;""<>аннулирован"";H:H;""<>отклонен"")" 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]
Вариант 2, приходится ещё одним сообщением, так как превысил количество символов
[vba]
Код
Sub Разгруппировка_v2() 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) = "=СУММЕСЛИМН(P:P;D:D;A" & m + 1 & ";H:H;""<>аннулирован"";H:H;""<>отклонен"")" arr(m, 3) = "=СУММЕСЛИМН(R:R;D:D;A" & m + 1 & ";H:H;""<>аннулирован"";H:H;""<>отклонен"")" 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
Первый вариант работает без ошибок. Второй вариант интересный, почему-то раньше в голову не приходило исключать строки со словами "отклонен" и "аннулирован" из общей суммы. Спасибо ОГРОМНОЕ.
Первый вариант работает без ошибок. Второй вариант интересный, почему-то раньше в голову не приходило исключать строки со словами "отклонен" и "аннулирован" из общей суммы. Спасибо ОГРОМНОЕ.smugi
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
Я забыла написать про макрос, который находился внутри макроса ОСТАЛЬНОЕ. у меня еще должны были удалятся строки где есть слова "отклонен" и "аннулирован". Чтоб не создавать тему, его можно также добавить в ВАШ макрос?
