Option Explicit
Sub SplitActiveWorkbook()
CloseEmptyWb
SplitWorkbook ActiveWorkbook
End Sub
Private Sub SplitWorkbook(wbFrom As Workbook)
Dim divisions As Object
Set divisions = GetDivisions(wbFrom, "Итого", 2)
If divisions.Count = 0 Then Exit Sub
Application.ScreenUpdating = False
Dim division As Variant
For Each division In divisions
Application.StatusBar = division
ExtractOneDivision division, wbFrom
Next
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Готово.", vbInformation, "Разделить книгу"
End Sub
Private Sub ExtractOneDivision(ByVal division As String, wbFrom As Workbook)
Dim wbTarg As Workbook
Set wbTarg = Workbooks.Add(1)
Dim sh As Worksheet
For Each sh In wbFrom.Worksheets
If sh.Visible = xlSheetVisible Then
If WorksheetFunction.CountIfs(sh.UsedRange.Columns(1), division) > 0 Then
ExtractOneDivisionFromSheet division, sh, wbTarg
End If
End If
Next
If wbTarg.Sheets.Count = 1 Then
wbTarg.Close False
Else
Application.DisplayAlerts = False
wbTarg.Sheets(1).Delete
Application.DisplayAlerts = True
SaveWorkbook wbTarg, division, wbFrom.Path & "\"
wbTarg.Close False
End If
End Sub
Private Sub SaveWorkbook(wb As Workbook, division As String, sPath As String)
Dim sName As String
sName = division
ReplaceSymbols sName
sName = sName & ".xlsx"
Dim sFull As String
sFull = sPath & sName
On Error Resume Next
Workbooks(sName).Close False
Kill sFull
On Error GoTo 0
wb.SaveAs sName
End Sub
Private Sub ExtractOneDivisionFromSheet(division As String, shFrom As Worksheet, wbTarg As Workbook)
shFrom.Copy After:=wbTarg.Sheets(wbTarg.Sheets.Count)
Dim shTarg As Worksheet
Set shTarg = wbTarg.Sheets(wbTarg.Sheets.Count)
Dim rd As Range
Set rd = shTarg.UsedRange.Columns(1)
Dim yb As Long
On Error Resume Next
yb = WorksheetFunction.Match(division, rd, 0)
On Error GoTo 0
If yb = 0 Then Exit Sub
Dim divIndentLevel As Long
divIndentLevel = rd.Cells(yb, 1).IndentLevel
Dim yf As Long
For yf = yb + 1 To rd.Rows.Count
If rd.Cells(yf, 1).IndentLevel <= divIndentLevel Then Exit For
Next
yf = yf - 1
If yf < rd.Rows.Count Then
With shTarg
.Range(rd.Cells(yf + 1), rd.Cells(rd.Rows.Count, 1)).EntireRow.Delete
End With
End If
Dim yy As Long
For yy = yb - 1 To 1 Step -1
If rd.Cells(yy, 1).IndentLevel >= divIndentLevel Then
rd.Cells(yy).EntireRow.Delete
End If
Next
End Sub
Private Function GetDivisionIndentLevel(rd As Range, division As String) As Long
Dim yy As Long
On Error Resume Next
yy = WorksheetFunction.Match(division, rd, 0)
On Error GoTo 0
If yy > 0 Then
GetDivisionIndentLevel = rd.Cells(yy, 1).IndentLevel
End If
End Function
Private Function GetDivisions(wb As Workbook, sheetName As String, needIndentLevel As Long) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim sh As Worksheet
On Error Resume Next
Set sh = wb.Sheets(sheetName)
On Error GoTo 0
If Not sh Is Nothing Then
Dim cl As Range
For Each cl In sh.UsedRange.Columns(1).Cells
If cl.IndentLevel = needIndentLevel Then
dic(cl.Value) = 0
End If
Next
End If
Set GetDivisions = dic
End Function
Private Sub ReplaceSymbols(ss As String)
Dim vv As Variant
For Each vv In Array("\", "/", ":", "*", "?", """", "<", ">", "|", "[", "]") '[] недопустимые только в имени листа
ss = Replace(ss, vv, " ")
Next
End Sub
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
|