Страницы: 1
RSS
Сборка листов в новую книгу
 
Добрый день.

Помогите доработать макрос по сборке информации из книги.
Суть такова:
В книге 6 листов, листы 1-3 имеют одну структуру, листы 4-6 другую. Макрос собирает информацию со всех листов в новую книгу. Причем собирает именно те данные, которые были заранее отфильтрованы.
На работу макроса нареканий нет, но прошу помощи добавить пару процедур. Необходимо разделить выходные данные на 2 книги: с листа 1-3 в новую книгу 1, с листа 4-6 в новую книгу 2 (всё в формате .xls)
И можно ли ограничить в макросе диапазон сбора данных до определённого количества столбцов? (пример: с листа 1-3 нужны только первые 12 столбцов, а с листа 4-6 первые 20)
Макрос:
Код
Sub consolidation()
s_ = Sheets.Count
Workbooks.Add
ThisWorkbook.Sheets(1).Range("1:1".Copy ActiveWorkbook.Sheets(1).Range("a1"
For i = 1 To s_
    r_ = ActiveWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp).Row + 1
    ThisWorkbook.Sheets(i).Range("a1".CurrentRegion.Offset(1).Copy ActiveWorkbook.Sheets(1).Range("a" & r_)
Next
End Sub
 
Код
Sub consolidation()
s_ = Sheets.Count
Workbooks.Add
ThisWorkbook.Sheets(1).Range("1:1").Copy ActiveWorkbook.Sheets(1).Range("a1")
For i = 1 To 3
    r_ = ActiveWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp).Row + 1
    ThisWorkbook.Sheets(i).Range("a1").CurrentRegion.Offset(1).Resize(,12).Copy ActiveWorkbook.Sheets(1).Range("a" & r_)
Next

Workbooks.Add
For i = 4 To s_
    r_ = ActiveWorkbook.Sheets(1).Range("a") & Rows.Count).End(xlUp).Row + 1
    ThisWorkbook.Sheets(i).Range("a1".CurrentRegion.Offset(1).Resize(,20).Copy ActiveWorkbook.Sheets(1).Range("a" & r_)
Next

End Sub
Со cкобками сами разбирайтесь, они у вас в коде пропадают периодически.
Изменено: TheBestOfTheBest - 08.04.2015 17:24:55
Неизлечимых болезней нет, есть неизлечимые люди.
 
Спасибо!

Подправил, чтобы и во вторую книгу шапку писал:
Код
Sub consolidation()
s_ = Sheets.Count
Workbooks.Add
ThisWorkbook.Sheets(1).Range("1:1").Copy ActiveWorkbook.Sheets(1).Range("a1")
For i = 1 To 3
    r_ = ActiveWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp).Row + 1
    ThisWorkbook.Sheets(i).Range("a1").CurrentRegion.Offset(1).Resize(, 12).Copy ActiveWorkbook.Sheets(1).Range("a" & r_)
Next
 
Workbooks.Add
ThisWorkbook.Sheets(4).Range("1:1").Copy ActiveWorkbook.Sheets(1).Range("a1")
For i = 4 To s_
    r_ = ActiveWorkbook.Sheets(1).Range("a" & Rows.Count).End(xlUp).Row + 1
    ThisWorkbook.Sheets(i).Range("a1").CurrentRegion.Offset(1).Resize(, 20).Copy ActiveWorkbook.Sheets(1).Range("a" & r_)
Next
 
End Sub
 
Только вот непонятно одна штука:
Вроде бы код одинаковый на перенос в новые книги, но в первом варианте переносит вместе с формулами, а во втором только значения. Почему так получается?
 
Возможно ApplicationCutCopy = False в стр.9 поможет.
Неизлечимых болезней нет, есть неизлечимые люди.
 
странно..
в 2013 попробовал - работает отлично а в 2010 с большими данными почему-то вторая книга получается без формул, только значения.

как задать, чтобы везде только значения были?
в 9 стр. ApplicationCutCopy = False не помогает.
Изменено: Борис - 08.04.2015 21:45:04 (убрал цитату)
 
Так, например
Код
ThisWorkbook.Sheets(i).Range("a1").CurrentRegion.Offset(1).Resize(, 12).Copy 
ActiveWorkbook.Sheets(1).Range("a" & r_).PasteSpecial XlPasteType:=xlPasteValues
Неизлечимых болезней нет, есть неизлечимые люди.
 
ругается.
Изменено: Борис - 08.04.2015 21:45:15 (убрал цитату)
 
.PasteSpecial Paste:=xlPasteValues описка
Неизлечимых болезней нет, есть неизлечимые люди.
 
Больше не ругается :) спасибо!
во вложении рабочий файл. Надеюсь кому-нибудь пригодится.
Страницы: 1
Наверх