Добрый день! В теме Разделить лист на книги представлен очень эффективный код, который делит лист на книги в соответствии с данными на одном листе: [vba]
Код
Public Sub www() Dim i&, a a = [a1].CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a): .Item(a(i, 1)) = "": Next a = .keys End With For i = 0 To UBound(a) Sheets(1).Copy With ActiveSheet.[a1].CurrentRegion .AutoFilter 1, "<>" & a(i) .Offset(1).SpecialCells(12).EntireRow.Delete With .Parent .AutoFilterMode = 0: .Name = a(i) .Parent.SaveAs ThisWorkbook.Path & "\" & a(i) & ".xlsx", 51 .Parent.Close End With End With Next End Sub
[/vba] Подскажите, что добавить в данный код, чтобы книги создавались сразу с несколькими листами в соответствии с одним и тем же уникальным полем на каждом листе? Прикладываю пример. На первых 3 листах - исходная информация, а на следующих 3 листах - результирующий файл с нужными листами для значения "а1".
Добрый день! В теме Разделить лист на книги представлен очень эффективный код, который делит лист на книги в соответствии с данными на одном листе: [vba]
Код
Public Sub www() Dim i&, a a = [a1].CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a): .Item(a(i, 1)) = "": Next a = .keys End With For i = 0 To UBound(a) Sheets(1).Copy With ActiveSheet.[a1].CurrentRegion .AutoFilter 1, "<>" & a(i) .Offset(1).SpecialCells(12).EntireRow.Delete With .Parent .AutoFilterMode = 0: .Name = a(i) .Parent.SaveAs ThisWorkbook.Path & "\" & a(i) & ".xlsx", 51 .Parent.Close End With End With Next End Sub
[/vba] Подскажите, что добавить в данный код, чтобы книги создавались сразу с несколькими листами в соответствии с одним и тем же уникальным полем на каждом листе? Прикладываю пример. На первых 3 листах - исходная информация, а на следующих 3 листах - результирующий файл с нужными листами для значения "а1".Мурад
Мурад, здравствуйте. Если на всех листах набор уникальных значений одинаковый, можно так: [vba]
Код
Public Sub www() Application.ScreenUpdating = False Dim i&, a, sh As Worksheet a = [a1].CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a): .Item(a(i, 1)) = "": Next a = .keys End With For i = 0 To UBound(a) ThisWorkbook.Sheets.Copy For Each sh In ActiveWorkbook.Sheets n = sh.Cells.Find(what:="столбец_уникальный", LookAt:=xlWhole).Column With sh.[a1].CurrentRegion .AutoFilter n, "<>" & a(i) .Offset(1).SpecialCells(12).EntireRow.Delete sh.AutoFilterMode = 0 End With Next sh With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & a(i) & ".xlsx", 51 .Close End With Next Application.ScreenUpdating = True End Sub
[/vba]
Мурад, здравствуйте. Если на всех листах набор уникальных значений одинаковый, можно так: [vba]
Код
Public Sub www() Application.ScreenUpdating = False Dim i&, a, sh As Worksheet a = [a1].CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a): .Item(a(i, 1)) = "": Next a = .keys End With For i = 0 To UBound(a) ThisWorkbook.Sheets.Copy For Each sh In ActiveWorkbook.Sheets n = sh.Cells.Find(what:="столбец_уникальный", LookAt:=xlWhole).Column With sh.[a1].CurrentRegion .AutoFilter n, "<>" & a(i) .Offset(1).SpecialCells(12).EntireRow.Delete sh.AutoFilterMode = 0 End With Next sh With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & a(i) & ".xlsx", 51 .Close End With Next Application.ScreenUpdating = True End Sub
Manyasha, спасибо большое! Я так понял, это код для вставки в модуль книги, а не в личную книгу макросов. Скажите, а числа 12 и 51 в коде что означают?
Manyasha, спасибо большое! Я так понял, это код для вставки в модуль книги, а не в личную книгу макросов. Скажите, а числа 12 и 51 в коде что означают?Мурад
Я применил данный код к своему массиву, но выходит ошибка "Метод Autofilter из класса Range завершен неверно". В моем массиве 4 листа. Уникальное поле расположено по порядку: в 1,1,2,1 столбцах каждого листа. Если это важно, размеры данных на листах (Строки х Столбцы): 231х27, 6166х17, 443х10, 246х7
Я применил данный код к своему массиву, но выходит ошибка "Метод Autofilter из класса Range завершен неверно". В моем массиве 4 листа. Уникальное поле расположено по порядку: в 1,1,2,1 столбцах каждого листа. Если это важно, размеры данных на листах (Строки х Столбцы): 231х27, 6166х17, 443х10, 246х7Мурад
У Вас там нехорошие куски автофильтра стоят на листах 3 и 4 Макрос Марины можно вот так немного дополнить на этот случай (строки с дополнением обозначил ===) [vba]
Код
Public Sub www() Application.ScreenUpdating = False Application.DisplayAlerts = 0 '===чтобы не спрашивал при переписывании файла Dim i&, a, sh As Worksheet, n '===добавил объявление n на случай Option Explicit a = [a1].CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a): .Item(a(i, 1)) = "": Next a = .keys End With For i = 0 To UBound(a) ThisWorkbook.Sheets.Copy For Each sh In ActiveWorkbook.Sheets n = sh.Cells.Find(what:="ID_VUZ", LookAt:=xlWhole).Column '===поменял название столбца для проверки With sh.[a1].CurrentRegion If sh.AutoFilterMode Then '===если автофильтр на листе есть .AutoFilter '===снимаем его End If '=== .AutoFilter n, "<>" & a(i) .Offset(1).SpecialCells(12).EntireRow.Delete sh.AutoFilterMode = 0 End With Next sh With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & a(i) & ".xlsx", 51 .Close End With Next Application.DisplayAlerts = 1 '=== Application.ScreenUpdating = True End Sub
[/vba]
У Вас там нехорошие куски автофильтра стоят на листах 3 и 4 Макрос Марины можно вот так немного дополнить на этот случай (строки с дополнением обозначил ===) [vba]
Код
Public Sub www() Application.ScreenUpdating = False Application.DisplayAlerts = 0 '===чтобы не спрашивал при переписывании файла Dim i&, a, sh As Worksheet, n '===добавил объявление n на случай Option Explicit a = [a1].CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a): .Item(a(i, 1)) = "": Next a = .keys End With For i = 0 To UBound(a) ThisWorkbook.Sheets.Copy For Each sh In ActiveWorkbook.Sheets n = sh.Cells.Find(what:="ID_VUZ", LookAt:=xlWhole).Column '===поменял название столбца для проверки With sh.[a1].CurrentRegion If sh.AutoFilterMode Then '===если автофильтр на листе есть .AutoFilter '===снимаем его End If '=== .AutoFilter n, "<>" & a(i) .Offset(1).SpecialCells(12).EntireRow.Delete sh.AutoFilterMode = 0 End With Next sh With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & a(i) & ".xlsx", 51 .Close End With Next Application.DisplayAlerts = 1 '=== Application.ScreenUpdating = True End Sub