Создание новых книг из текущей по условию

Пользователь

Сообщений: 45 Регистрация: 19.01.2015

20.10.2015 11:41:15

Добрый день, уважаемые форумчане.
Помогите пожалуйста "допилить" найденный на этом форуме макрос. Не хватает умения и знаний:(
Макрос из листа "Данные", копирует все строки по условию строки "L", создает новые книги в этой же папке где находится файл по уникальным значениям на листе "Список".
Все замечательно, но вот только не вставляет он "шапку таблицы", а она очень нужна. Шапка одинаковая, как в исходнике

Методом тыка копируемые строки подогнал, но вот с задачей описанной выше никак не справлюсь.
Заранее спасибо за любую помощь.

Пример в приложении

Прикрепленные файлы

дороботка.xlsm (26.35 КБ)

yoozhik

Пользователь

Сообщений: 239 Регистрация: 01.01.1970

20.10.2015 11:54:08

Код

Sub test()
Dim i As Integer
Dim ilist As Integer
Dim xlbookname As String
Dim y As Integer
Set xlbook = ActiveWorkbook
Dim rng As Range
Set rng = xlbook.Sheets("Данные").Range("A1:M4")
For i = 1 To xlbook.Sheets("Список").Cells(Rows.Count, 1).End(xlUp).Row
xlbookname = xlbook.Sheets("Список").Cells(i, 1)
y = 5
Set xlbooknew = Workbooks.Add
rng.Copy Destination:=[a1]
For ilist = 1 To xlbook.Sheets("Данные").Cells(Rows.Count, 2).End(xlUp).Row
If xlbook.Sheets("Данные").Cells(ilist, 12) = xlbookname Then
xlbook.Sheets("Данные").Rows(ilist).Copy xlbooknew.Sheets(1).Rows(y)
y = y + 1
End If
Next
xlbooknew.SaveAs xlbook.Path & "\" & xlbookname & ".xls"
xlbooknew.Close
Next
End Sub

igor_ber Пользователь Сообщений: 45 Регистрация: 19.01.2015	#3 20.10.2015 12:00:04 yoozhik спасибо большое за очень быстрый ответ)