Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
макрос разбивает файл на несколько по данным столбца
 
#1
17.09.2019 17:52:44
Добрый день,

Поомогите:
При запуске макроса, выбирается столбец по которому разбивается файл, например "P"
В итоге получаем файлы:
Сверка цен 16.09.19_ПТ-2 (в файлах отображаются все строки, которые имеют значение категории ПТ-2 )
Сверка цен 16.09.19_НТ-1(в файлах отображаются все строки, которые имеют значение категории НТ-1 )

Частично что-то попытался написать, но дальше никак, исходник и макросы во вложении.
 
 
 
#2
17.09.2019 19:17:36
(файл не смотрела)
по названию темы - варианты в ветке - Разделить одну таблицу excel, на несколько по определенному критерию
Изменено: JeyCi - 17.09.2019 19:18:41
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
 
 
#3
17.09.2019 23:40:26
Код
Sub RaznestiDannye()
Dim i As Long
Dim n As Long
Dim Criterij As String
Dim iName As String
Dim WCur As Worksheet
Dim WbN As Workbook
Dim AutoFilter As AutoFilter
Application.ScreenUpdating = False
   Set WCur = ThisWorkbook.Worksheets("Лист1")
   Columns("R").ClearContents
          'отбор уникальных значений столбца Р в столбец R
    Range("P1:P" & Cells(Rows.Count, "P").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("R1"), Unique:=True
          'количество уникальных значений категорий
    n = Cells(Rows.Count, "R").End(xlUp).Row
    For i = 2 To n          'цикл по уникальным значениям категорий
        Criterij = Cells(i, "R")
        iName = Criterij    'имя новой книги
    'создаем новую книгу с одним листом
      Set WbN = Workbooks.Add(xlWBATWorksheet)
    'ставим автофильтр по столбцу P
          WCur.Range("P1").CurrentRegion.AutoFilter 16, Criterij
    'копируем видимые строки в новую книгу
        WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1")
        WCur.AutoFilter.Range.AutoFilter
         
        WbN.Sheets("Лист1").Columns("A:P").AutoFit
        WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
        WbN.Close SaveChanges:=True
    Next
Application.ScreenUpdating = True
End Sub
Сохранение новых файлов по имени категорий в ту же папку, где и исходный файл
 
 
 
#4
18.09.2019 09:19:44
Kuzmich, гениально!!!
Спасибо огромное!!!

можно еще одно изменение?
Чтобы названия новых созданных файлов было не просто название категории (критерия) отбора, а название "исходного файла_категория", то есть "Сверка цен 16.09.19_НТ-1", "Сверка цен 16.09.19_НТ-2".
я так понял надо изменить тут, но вот как не пойму (только учусь):
Код
WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"

Буду крайне благодарен!
 
 
 
#5
18.09.2019 11:30:19
Цитата
еще одно изменение
Определите имя текущей книги перед циклом  
Код
 Set WCur = ThisWorkbook.Worksheets("Лист1")
   CurName = WCur.Parent.Name    'выделяем имя текущей книги без расширения
   CurName = Left(CurName, InStrRev(CurName, ".") - 1) & "_"
А затем добавляем это имя в название новых файлов      
Код
 WbN.SaveAs ThisWorkbook.Path & "\" & CurName & iName & ".xls"
 
 
 
Страницы: 1
Наверх