может поможет:
код |
|---|
Sub цццц()
Application.ScreenUpdating = 0
For Each sh In Sheets
sh.UsedRange.AutoFilter Field:=1, Criteria1:=""
sh.AutoFilter.Range.Offset(1).Delete Shift:=xlUp
sh.AutoFilterMode = 0
Next sh
vremya = format(Now, "DD-MM-YYYY HH-MM-SS" ;)
MkDir (CreateObject("WScript.Shell" ;) .SpecialFolders("Desktop" ;) & "\ЦЦЦЦ " & vremya)
Dim ipoteka(1 To 30)
ipoteka(1) = 59: ipoteka(2) = 68: ipoteka(3) = 88' и так далее ...
For qqq = 1 To 37
Sheets.Copy
For Each Sheet In Sheets
Sheet.Rows("2:2" ;) .AutoFilter Field:=1, Criteria1:="<>" & ipoteka(qqq)
Sheet.AutoFilter.Range.Offset(1).Delete Shift:=xlUp
Sheet.AutoFilterMode = 0
Next Sheet
a = 0
For i = 1 To Sheets.Count
a = a + Sheets(i).Range("a3" ;) .Value
Next i
If a = 0 Then ActiveWorkbook.Close False: GoTo 1
For Each S In Sheets
Application.DisplayAlerts = 0
If Not S.Range("a3" ;) .Value > 0 Then S.Delete
Application.DisplayAlerts = 1
Next S
ActiveWorkbook.SaveAs CreateObject("WScript.Shell" ;) .SpecialFolders("Desktop" ;) & "\ÔÈËÈÀËËÀÐÃÀ " & vremya & "\" & ipoteka(qqq) & ".xls", FileFormat:=xlNormal
ActiveWorkbook.Close
1: Next qqq
ThisWorkbook.Close False
Application.ScreenUpdating = 1
End Sub |
этот код вставляет в строку №2 фильтр и по заданным критериям (элементы масива ipoteka) отбирает нужные строки, и по результату каждого критерия сохраяет отдельную книгу EXCEL в отдельную папку.
То есть если у вас в книге два листа "Продажи" и "Телефоны" и в обеих листах одни и те же фирмы, и если стоит задача сохранить в отдельную книгу данные по каждой фирме отдельно, то этот макрос должен вам помочь.
AutoFilter Field:=1, то есть у меня данные выбыраются по первому столбцу а вы можете изменить
