Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Разделение листа на отдельные книги по критерию
 
#1
22.04.2019 16:30:42
Есть некий список школы !! Необходимо создать файлы со списком классов( разбить этот файл на классы ) заголовок в каждом один и тот же имя файла из ячейки столбца А.  
 
 
 
#2
22.04.2019 16:43:41
Цитата
sokolovssv написал:
Необходимо создать файлы
Кому необходимо? Кому задачу ставите?
 
 
 
#3
22.04.2019 16:45:32
Мне необходимо! незнаю с чего начать может кто напрвит на путь истинный. Спасибо!
 
 
 
#4
24.04.2019 18:43:31
Цитата
незнаю с чего начать может кто напрвит на путь истинный
Пишите макрос.
1.Определяете диапазон ячеек, принадлежащих определенному классу.
2.Создаете новую книгу с одним листом и копируете в нее этот диапазон.
3.Присваиваете книге имя соответствующего класса.
4.Сохраняете книгу в нужном месте.
5. Переходите к пункту 1 для следующего класса
 
 
 
#5
26.04.2019 08:46:21
Всем спасибо! сделал ! Отдельное спасибо CrazyRabbit его код из поста https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=90168&MID=s помог. Взял за основу!!
Получилось что то типа:             для первого раза не судите строго!!!


Sub ssv()
           Application.ScreenUpdating = False
           Application.Calculation = xlCalculationManual
           
         
           
   Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Ëèñò1"
   
Не знал как копировать формат и ширину ячеек придумал вот это!! Я уверен что есть путь легче но вот както так
  Sheets("pMain").Select
   Range("B1:W1").Select
   Selection.Copy
   Sheets("Ëèñò1").Select
   Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
       SkipBlanks:=False, Transpose:=False
   
   
   
           
Dim w1 As Worksheet: Set w1 = ThisWorkbook.Sheets("pMain")
 Dim w2 As Worksheet: Set w2 = ThisWorkbook.Sheets("Ëèñò1")
Dim i As Long
   i = w1.Cells(Rows.Count, 1).End(xlUp).Row
   w2.Cells.Clear
   w1.Range("B1:W1").Copy w2.Cells(1, 1) '.xlPasteColumnWidths
   
   For n = 2 To i
       If w1.Range("A" & n) <> "" Then
           w2.Cells.Clear
           w1.Range("B1:W1").Copy w2.Cells(1, 1)
           q = n + 1
           Do While w1.Range("B" & q + 1) <> ""
           
           'Do While w1.Range("D" & q + 1) = w1.Range("D" & n + 1)
               q = q + 1
           Loop
           w1.Range("B" & n + 1 & ":W" & q).Copy w2.Range("A2")
           Name = ""
                    Name = w1.Range("A" & n)
           Sheets("Ëèñò1").Select
   Sheets("Ëèñò1").Copy
   Sheets("Ëèñò1").Select
   Sheets("Ëèñò1").Name = "pMain"
            ActiveWorkbook.SaveAs Filename:="D:\sss\" & Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   ActiveWorkbook.Close
       End If
   Next n
   Application.DisplayAlerts = False
   w2.Delete
   Application.DisplayAlerts = True
       Application.ScreenUpdating = True
       Application.Calculation = xlCalculationAutomatic
End Sub
 
 
 
#6
26.04.2019 10:30:20
Цитата
разбить этот файл на классы
Код
Sub Raznesti()
Dim Rng As Range
Dim iLastRow As Long
Dim iName As String
Dim pMain As Worksheet
Application.ScreenUpdating = False
  Set pMain = ThisWorkbook.Worksheets("pMain")
  iLastRow = Cells(Rows.Count, 2).End(xlUp).Row
    For Each Rng In Range("B3:E" & iLastRow).SpecialCells(xlCellTypeConstants, 2).Areas
     iName = Rng.Cells(0, 0)                          'очередной класс
       Workbooks.Add (xlWBATWorksheet)                'добавляем книгу с одним листом
        pMain.Range("A1:H1").Copy                     'копируем шапку таблицы
        Cells(1, 1).PasteSpecial xlPasteColumnWidths  'ширина столбцов в новой книге
        Cells(1, 1).PasteSpecial xlPasteValues        'вставляем шапку
        Rng.Copy Cells(2, 2)                          'копируем диапазон очеред.класса
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
        ActiveWorkbook.Close SaveChanges:=True        'сохраняем книгу с именем класса
    Next
Application.ScreenUpdating = True
End Sub
Файлы с именем класса создаются в той же директории, где и исходный файл
 
 
 
Страницы: 1
Наверх