Спасибо, вроде получилось перестроить под свою таблицу. Подскажите пожалуйста, как в данном примере переименовать лист, по умолчанию создается Лист1, а нужно другое конкретное имя.
| Код |
|---|
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 |
