Страницы: 1
RSS
Разбить один файл excel на несколько отдельных книг, по значениям в столбце
 
Добрый день!

Подскажите пожалуйста, есть ли такой макрос, который разбивает один файл, на несколько отдельных книг по значению в столбце? К примеру, во вложении файл. По нему запускается печать. Нужно каждой типографии отправить свои стороны с макетами. То есть на выходе должно получиться столько же отдельных книг, сколько и типографий, сложенных в одну папку.
Если может кто - то помочь, напишите пожалуйста макрос. Только максимально подробно, т. к. ранее никогда с макросами не работал. И идеале в самом макросе напишите, что, за то отвечает, т. к. иногда переменные могут меняться. То есть не только по типографиям, а к примеру по менеджерам.
Нашел где - то на просторах более менее подходящий макрос, но он почему то не работает, выдает ошибку. Может его получится исправить?

Вот тот самый макрос, который не работает:
Код
Sub Разнести_по_книгам()
Const cc = 6 ' столбец по которому разделять
Const шапка = False
Set wbAct = ActiveWorkbook

Set dic = CreateObject("Scripting.Dictionary")

lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column

arr = Range("A1", Cells(lr, lc)).Value

If шапка Then fr = 2 Else fr = 1

For i = fr To UBound(arr)
   If Trim(arr(i, cc)) <> "" Then dic.Item(arr(i, cc)) = dic.Item(arr(i, 2)) & "|" & i
Next

iPath = wbAct.Path & Application.PathSeparator & "Temp" & Application.PathSeparator
If Dir(iPath, vbDirectory) = "" Then MkDir iPath

arrDic = dic.keys
Set Rng = Nothing
Application.DisplayAlerts = False
For i = 0 To UBound(arrDic)
rrs = Split(Mid(dic.Item(arrDic(i)), 2), "|")
   If шапка Then Set Rng = Rows(1)
   For Each rr In rrs
       If Not Rng Is Nothing Then Set Rng = Union(Rows(rr), Rng) Else Set Rng = Rows(rr)
   Next
   Set wb = Workbooks.Add(1)
   Set sh = wb.Sheets(1)
   Rng.Copy
   sh.[A1].PasteSpecial xlPasteColumnWidths
   sh.[A1].PasteSpecial xlPasteAll
   Set Rng = Nothing
   wb.SaveAs iPath & arrDic(i) & ".xlsx", xlOpenXMLWorkbook
   wb.Close False
Next
Application.DisplayAlerts = True
End Sub
 
Поправил ваш макрос. См. файл. Макрос запускается по Alt+F8
Изменено: New - 23.11.2020 16:38:08
 
Все работает! Спасибо большое!!!
 
Поправил код, а то немного не так работал. Используйте этот файл
 
Еще раз, большое спасибо!
 
Добрый день!

Помогите доработать выше приведенный макрос под мои задачи. В макросах не силен.
Нужно чтобы:
- шапка в файлах с итогами разбивки содержала 5 и 6 строки (возможно больше строк) (Const HeaderRow = 6 'номер строки с шапкой таблице);
- наименование вновь создаваемых файлов в папке Temp содержало не только наименование условия отбора, но и данные из ячейки H2, т.е. наименование файла не просто Ракурс, а Ракурс_авг 2022
- существенным недостатком данного макроса для моей задачи является копирование и вставка данных не как значение, а с сохранением формул.
В идеале нужно чтобы значения из ячеек, имеющих формулы с ссылкой на другие листы вставлялись как значения (без сохранения формулы), а ячейки, имеющих формулы без ссылкой на другие листы сохраняли формулы. Не в идеале чтобы копирование и вставка данных во вновь созданные книги производилось как значение (без сохранения формулы).

Заранее спасибо откликнувшимся  
 
Цитата
написал:
В идеале нужно чтобы значения из ячеек, имеющих формулы с ссылкой на другие листы вставлялись как значения (без сохранения формулы), а ячейки, имеющих формулы без ссылкой на другие листы сохраняли формулы. Не в идеале чтобы копирование и вставка данных во вновь созданные книги производилось как значение (без сохранения формулы).
Уточнение, формат выборки должен сохранять формат первоисточника, т.е., заливка, шрифт, ширина столбцов, строк, должна сохраняться (в том числе и скрытые столбцы должны оставаться скрытыми, а не разворачиваться, либо удаляться)
 
Цитата
написал:
формат выборки должен сохранять формат первоисточника, т.е., заливка, шрифт, ширина столбцов, строк, должна сохраняться (в том числе и скрытые столбцы должны оставаться скрытыми, а не разворачиваться, либо удаляться)
Если так, то проще сделать "от обратного": скопировать полностью лист, а в нём потом оставить только те строки, которые нужны для каждого файла. Тогда всё форматирование сохранится по умолчанию.
Во вложенном файле так и сделано. Кроме того, согласно просьбе:
- В конечных файлах названия сделаны из названия клиента с добавлением месяца и года.
- Все формулы, ссылающиеся на другие листы или книги, заменены на значения. Формулы, относящиеся только к данному листу, оставлены.
 
tolikt огромное спасибо, очень помогли, все работает супер.
Но есть несколько моментов (файл пример во вложении):
- по столбцу D формула ссылающаяся на другой лист осталась формулой, а не перешла в значение
- в столбцах AK, AL комбинация не сработала, формулы ссылающиеся на текущий лист перешли в значения
- в столбцах AE-AK, AR, AX-BE все сработало как нужно, формулы ссылающиеся на др.листы перешли в значения, формулы ссылающиеся на тек.лист остались формулами
- цветовая палитра шапки в формируемых файлах выборки меняется, но это совершенно не принципиально.
Если кто то будет использовать макрос в текущей редакции, обратите внимание, макрос не отработает, если столбец условие будет скрыт
Изменено: Юрий - 07.08.2022 10:43:02
 
Да, макрос удаления в формулах ссылок на другие книги работает с глюками, о чём честно написано по адресу, откуда он был скопипастен: вверху Module2.
В таком случае процедуру эту, наверное, лучше будет делать по-другому - разрыв связей с другими книгами. Нашёл такой макрос:
Код
Sub BreakLinks()
    Dim vLinks As Variant
    Dim lLink As Long
    ' Define variable as an Excel link type.
    vLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
'    If vLinks = vbNullString Then Exit Sub
'    If IsEmpty(vLinks) Then Exit Sub
    If Not IsArray(vLinks) Then Exit Sub
    ' Break all links in the active workbook.
    For lLink = LBound(vLinks) To UBound(vLinks)
        ActiveWorkbook.BreakLink Name:=vLinks(lLink), Type:=xlLinkTypeExcelLinks
    Next lLink
End Sub
Вроде как работает, в т.ч. с формулами в скрытых столбцах, но сильно не гонял.

По изменению цвета шапки в копируемых листах - не понял. Лист просто копируется полностью, т.е. вместе с форматами и т.п., и далее никаких манипуляций с оформлением не производится. Цвета никак не должны меняться.
Изменено: tolikt - 07.08.2022 11:39:44
 
tolikt огромное спасибо, это то что нужно, вставил данный макрос в основной, отрабатывает как надо. Цвета заливки именно шапки меняются во вновь созданных книгах с выборкой, пока не могу понять почему, но это совершенно не принципиально. Выкладываю окончательный вариант, может кому пригодится  
Страницы: 1
Читают тему (гостей: 1)
Наверх