Option Explicit
Sub SplitByBranch()
On Error GoTo ErrorHandler
Dim wsNew As Worksheet
Dim Header As String, SheetName As String
Dim StartRow As Long, EndRow As Long, i As Long, p As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ThisWorkbook.Worksheets("Planilha1")
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim LastCol As Long
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Dim HeaderRow As Variant
HeaderRow = .Range(.Cells(1, 1), .Cells(1, LastCol)).Value
Dim r As Long
r = 1
Do While r <= LastRow
Header = Trim(.Cells(r, 1).Value)
If Left(Header, 16) = "Nome da filial: " Then
StartRow = r
EndRow = LastRow
For i = r + 1 To LastRow
If Left(Trim(.Cells(i, 1).Value), 16) = "Nome da filial: " Then
EndRow = i - 1
Exit For
End If
Next i
p = InStr(Header, " - ")
If p > 0 Then
SheetName = Mid(Header, p + 3)
If InStr(SheetName, "(") > 0 Then
SheetName = Left(SheetName, InStr(SheetName, "(") - 1)
End If
SheetName = Trim(SheetName)
SheetName = Split(SheetName, " ")(0)
Else
SheetName = "Sheet"
End If
SheetName = Replace(SheetName, "\", "")
SheetName = Replace(SheetName, "/", "")
SheetName = Replace(SheetName, ":", "")
SheetName = Replace(SheetName, "*", "")
SheetName = Replace(SheetName, "?", "")
SheetName = Replace(SheetName, "[", "")
SheetName = Replace(SheetName, "]", "")
If Len(SheetName) > 31 Then
SheetName = Left(SheetName, 31)
End If
If Not SheetExists(SheetName) Then
Set wsNew = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wsNew.Name = SheetName
wsNew.Range(wsNew.Cells(1, 1), wsNew.Cells(1, LastCol)).Value = HeaderRow
If EndRow >= StartRow + 1 Then
.Range(.Cells(StartRow + 1, 1), .Cells(EndRow, LastCol)).Copy _
Destination:=wsNew.Cells(2, 1)
End If
End If
r = EndRow + 1
Else
r = r + 1
End If
Loop
End With
ExitHandler:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical
Resume ExitHandler
End Sub
Private Function SheetExists(ByVal SheetName As String) As Boolean
On Error Resume Next
SheetExists = Not ThisWorkbook.Worksheets(SheetName) Is Nothing
On Error GoTo 0
End Function
