Есть некий список школы !! Необходимо создать файлы со списком классов( разбить этот файл на классы ) заголовок в каждом один и тот же имя файла из ячейки столбца А.
Разделение листа на отдельные книги по критерию
22.04.2019 16:30:42
|
|
|
|
22.04.2019 16:43:41
|
|||
|
|
22.04.2019 16:45:32
Мне необходимо! незнаю с чего начать может кто напрвит на путь истинный. Спасибо!
|
|
|
|
26.04.2019 08:46:21
Всем спасибо! сделал ! Отдельное спасибо
Получилось что то типа: для первого раза не судите строго!!! 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 |
|
|
|
26.04.2019 10:30:20
|
|||||
|
|
||||