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