Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Нарезка таблицы на отдельные книги (макрос в книге с исходной таблицей)
 
#1
06.12.2019 01:35:19
Добрый вечер!
Нашел в сети макрос, который открывает другую книгу и режет ее на отдельные книги фильтрацией.
Мне же нужно, чтобы макрос находился в книге с таблицей. Пытался его адаптировать, но нарезка не происходит.
Подскажите, пожалуйста, что я не так делаю?

Предполагается, что в таблицу (кол-во столбцов всегда одинаковое) вносятся данные, а затем запускается в этой же книге макрос, который режет на отдельные книги таблицу. Критерием фильтрации для нарезки должен быть столбец В (номер договора).
 
 
 
#2
06.12.2019 13:51:10
Цитата
Нашел в сети макрос, который открывает другую книгу и режет ее на отдельные книги фильтрацией.
В книге макрос предлагает вам выбрать папку, в которую будет происходить нарезка, но не открывает другую книгу.
Разбираться в чужом коде нет желания. Посмотрите макрос, который режет вашу таблицу на отдельные листы.
Код
Sub iDogovor()
Dim i As Long
Dim n As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("Исходник")
        Columns("AZ").ClearContents
     'отбор уникальных значений столбца B в столбец AZ
    Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("AZ1"), Unique:=True
     'количество уникальных значений
        n = Cells(Rows.Count, "AZ").End(xlUp).Row
    For i = 2 To n          'цикл по уникальным значениям
        Criterij = Sht.Cells(i, "AZ")
        iName = Criterij    'имя нового листа
     'ставим автофильтр по столбцу B
       Sht.Range("A1:AS" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row).AutoFilter 2, Criterij
     'копируем видимые строки в новый лист
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets.Add(After:=Worksheets(Worksheets.Count))  'добавляет новый лист в конец
          .Range("A1:AS1").PasteSpecial xlPasteColumnWidths
          .Range("A1:AS1").PasteSpecial xlPasteFormats
          .Range("A1:AS1").PasteSpecial xlPasteValues
          Sht.AutoFilter.Range.AutoFilter
          .Name = iName
          .Range("A1").Select
        End With
    Next
      Sht.Activate
Application.ScreenUpdating = True
End Sub
 
 
 
#3
06.12.2019 17:04:38
Kuzmich, спасибо! Но можно ли все-таки докрутить, чтобы нарезка шла не на отдельные листы в этой же книге, а создавались новые книги с указанием папки, в которую складывать?
 
 
 
Страницы: 1
Наверх