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

Вход

Регистрация

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

 

= Мир MS Excel/Разделить лист на книги - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Разделить лист на книги (Excel)
Разделить лист на книги
DJ_Marker_MC Дата: Пятница, 21.02.2014, 20:27 | Сообщение № 1
Группа: Друзья
Ранг: Ветеран
Сообщений: 991
Репутация: 213 ±
Замечаний: 0% ±

Excel 2019
Всем добрый вечер, навеяло на создание данной темы, мой прошлый вопрос в разделе VBA.

Данный макрос делит лист на книги по условию с нужного Вам столбца в котором находятся какие либо данные.

Не привык присваивать чужие заслуги, поэтому говорю сразу данный код, 98 его процентов, принадлежит KuklP
Но у меня давно было желание получить такой код в универсальном виде, поэтому я его немножко подправил, внёс несколько дополительных переменных и заменил кое что.

Итак сам код в откорректированном виде:
[vba]
Код
Public Sub CutFile()
        Dim i&, a
        Dim Shapka%, ident%, lastRow, lastCol
            
        lastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lastCol = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        Shapka = InputBox("Укажите номер строки шапки таблицы")
        ident = InputBox("Укажите номер столбца по которому будет происходить деление файла")
            
        a = Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
        With CreateObject("scripting.dictionary")
            For i = 2 To UBound(a): .Item(a(i, ident)) = "": Next
            a = .keys
        End With
        For i = 0 To UBound(a)
            Sheets(1).Copy
            With Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
                .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]

я заменил изначальный CurrentRegion на Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
Объясню почему, у меня в таблице ситуация такая, что строчка над шапкой таблицы имеет записи и таким образом при установке фильтра он устанавливался не в шапке, а строкой выше, для этого нужен был офсет и танцы с бубном, чтоб от этого уйти, решил правильнее указывать готовый диапазон всей таблицы.
Также добавил два InputBox для того чтоб указать в какой строке у Вас находится шапка и по какому столбцу будем делить файл.
Для большего понимая прилаживаю примерчик.
К сообщению приложен файл: 7594009.xlsm (20.5 Kb)


Сообщение отредактировал DJ_Marker_MC - Пятница, 21.02.2014, 20:29
 
Ответить
СообщениеВсем добрый вечер, навеяло на создание данной темы, мой прошлый вопрос в разделе VBA.

Данный макрос делит лист на книги по условию с нужного Вам столбца в котором находятся какие либо данные.

Не привык присваивать чужие заслуги, поэтому говорю сразу данный код, 98 его процентов, принадлежит KuklP
Но у меня давно было желание получить такой код в универсальном виде, поэтому я его немножко подправил, внёс несколько дополительных переменных и заменил кое что.

Итак сам код в откорректированном виде:
[vba]
Код
Public Sub CutFile()
        Dim i&, a
        Dim Shapka%, ident%, lastRow, lastCol
            
        lastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        lastCol = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        Shapka = InputBox("Укажите номер строки шапки таблицы")
        ident = InputBox("Укажите номер столбца по которому будет происходить деление файла")
            
        a = Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
        With CreateObject("scripting.dictionary")
            For i = 2 To UBound(a): .Item(a(i, ident)) = "": Next
            a = .keys
        End With
        For i = 0 To UBound(a)
            Sheets(1).Copy
            With Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
                .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]

я заменил изначальный CurrentRegion на Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
Объясню почему, у меня в таблице ситуация такая, что строчка над шапкой таблицы имеет записи и таким образом при установке фильтра он устанавливался не в шапке, а строкой выше, для этого нужен был офсет и танцы с бубном, чтоб от этого уйти, решил правильнее указывать готовый диапазон всей таблицы.
Также добавил два InputBox для того чтоб указать в какой строке у Вас находится шапка и по какому столбцу будем делить файл.
Для большего понимая прилаживаю примерчик.
Автор - DJ_Marker_MC
Дата добавления - 21.02.2014 в 20:27
DJ_Marker_MC Дата: Понедельник, 24.02.2014, 19:18 | Сообщение № 2
Группа: Друзья
Ранг: Ветеран
Сообщений: 991
Репутация: 213 ±
Замечаний: 0% ±

Excel 2019
Немного подправил код. Не работал отбор, если столбец был не первым... Теперь всё ок, где бы не находилась шапка или столбец по которому нужно делить, всё делит без проблем:

[vba]
Код
Public Sub CutFile()
         Dim i&, a
         Dim Shapka%, ident%, lastRow, lastCol
              
         lastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
         lastCol = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
         Shapka = InputBox("Укажите номер строки шапки таблицы")
         ident = InputBox("Укажите номер столбца по которому будет происходить деление файла")
              
         a = Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
         With CreateObject("scripting.dictionary")
             For i = 2 To UBound(a): .Item(a(i, ident)) = "": Next
             a = .keys
         End With
         For i = 0 To UBound(a)
             Sheets(1).Copy
             With Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
                 .AutoFilter ident, "<>" & 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]
К сообщению приложен файл: 7337985.xlsm (20.6 Kb)
 
Ответить
СообщениеНемного подправил код. Не работал отбор, если столбец был не первым... Теперь всё ок, где бы не находилась шапка или столбец по которому нужно делить, всё делит без проблем:

[vba]
Код
Public Sub CutFile()
         Dim i&, a
         Dim Shapka%, ident%, lastRow, lastCol
              
         lastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
         lastCol = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
         Shapka = InputBox("Укажите номер строки шапки таблицы")
         ident = InputBox("Укажите номер столбца по которому будет происходить деление файла")
              
         a = Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
         With CreateObject("scripting.dictionary")
             For i = 2 To UBound(a): .Item(a(i, ident)) = "": Next
             a = .keys
         End With
         For i = 0 To UBound(a)
             Sheets(1).Copy
             With Range(Cells(Shapka, 1), Cells(lastRow, lastCol))
                 .AutoFilter ident, "<>" & 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]
Автор - DJ_Marker_MC
Дата добавления - 24.02.2014 в 19:18
Мир MS Excel » Вопросы и решения » Готовые решения » Разделить лист на книги (Excel)
  • Страница 1 из 1
  • 1
Поиск:

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