Добрый день!
Подскажите пожалуйста, есть ли такой макрос, который разбивает один файл, на несколько отдельных книг по значению в столбце? К примеру, во вложении файл. По нему запускается печать. Нужно каждой типографии отправить свои стороны с макетами. То есть на выходе должно получиться столько же отдельных книг, сколько и типографий, сложенных в одну папку.
Если может кто - то помочь, напишите пожалуйста макрос. Только максимально подробно, т. к. ранее никогда с макросами не работал. И идеале в самом макросе напишите, что, за то отвечает, т. к. иногда переменные могут меняться. То есть не только по типографиям, а к примеру по менеджерам.
Нашел где - то на просторах более менее подходящий макрос, но он почему то не работает, выдает ошибку. Может его получится исправить?
Вот тот самый макрос, который не работает:
Подскажите пожалуйста, есть ли такой макрос, который разбивает один файл, на несколько отдельных книг по значению в столбце? К примеру, во вложении файл. По нему запускается печать. Нужно каждой типографии отправить свои стороны с макетами. То есть на выходе должно получиться столько же отдельных книг, сколько и типографий, сложенных в одну папку.
Если может кто - то помочь, напишите пожалуйста макрос. Только максимально подробно, т. к. ранее никогда с макросами не работал. И идеале в самом макросе напишите, что, за то отвечает, т. к. иногда переменные могут меняться. То есть не только по типографиям, а к примеру по менеджерам.
Нашел где - то на просторах более менее подходящий макрос, но он почему то не работает, выдает ошибку. Может его получится исправить?
Вот тот самый макрос, который не работает:
Код |
---|
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 |