Split ExcelSheet after separator - excel

Question

I have an Excel file, in the first sheet I have on column A some text delimited by a separator, like this:
Column A
--------
Text line 1.1
Text line 1.2
Text line 1.3
***
Text line 2.1
Text line 2.2
Text line 2.3
***
Text line 3.1
I like to split the content after the *** separator and put each piece in a separate file with only one sheet. The name of the files should be the first line of the each section.
I need to be able to copy with the formatting, colors, etc.
This is the function but is not copying the formatting...
Private Function AImport(ThisWorkbook As Workbook) As Boolean
Dim height As Long
Dim fileName As String
Dim startLine As Long
Dim endLine As Long
Dim tmpWs As Worksheet
Dim AnError As Boolean
With ThisWorkbook.Worksheets(1) 'sheet name "Sheet1"
height = .Cells(.rows.Count, 2).End(xlUp).row
startLine = 6
nr = 1
For i = startLine + 1 To height
If InStr(.Cells(i, 2).Value, "***") > 0 Then
separate = i
a = Format(nr, "00000")
fileName = "File" & a
endLine = separate - 1
.rows(startLine & ":" & endLine).Copy
Set tmpWs = ThisWorkbook.Worksheets.Add
tmpWs.Paste
tmpWs.Select
tmpWs.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fileName:=ThisWorkbook.path & "\Output\" & fileName & " .xls", FileFormat:=xlExcel8, CreateBackup:=False 'xlOpenXMLWorkbookMacroEnabled
ActiveWorkbook.Close
tmpWs.Delete
'update next start line
startLine = separate + 1
nr = nr + 1
End If
Next i
End With
If AnError Then
MsgBox "Errors detected in " & ThisWorkbook.Name & "! Check LogFile.txt file for details. Execution stopped!", vbExclamation, inputWb.Name
AImport = False
Else:
Application.StatusBar = "Workbook check succesfully completed. Executing macro..."
AImport = True
End If
ThisWorkbook.Close
End Function

Answer 1

Just give out a workable solution, surely not a good one
Sub testing()
Dim height As Long
Dim fileName As String
Dim startLine As Long
Dim endLine As Long
Dim tmpWs As Worksheet
With ThisWorkbook.Worksheets("Sheet2") ' Input your sheet name here
height = .Cells(.Rows.Count, 1).End(xlUp).Row
startLine = 3
For i = 2 To height
If InStr(.Cells(i, 1).Value, "***") > 0 Then
separate = i
fileName = .Cells(startLine, 1).Value
endLine = separate - 1
.Rows(startLine & ":" & endLine).Copy
Set tmpWs = ThisWorkbook.Worksheets.Add
tmpWs.Paste
tmpWs.Select
tmpWs.Copy
Application.DisplayAlerts = False
' in the following line, replace the file path with your own
ActiveWorkbook.SaveAs fileName:="H:\" & fileName & " .xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close
tmpWs.Delete
'update next start line
startLine = separate + 1
End If
Next i
'handline the last section here
endLine = height
fileName = .Cells(startLine, 1).Value
.Rows(startLine & ":" & endLine).Copy
Set tmpWs = ThisWorkbook.Worksheets.Add
tmpWs.Paste
tmpWs.Select
tmpWs.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fileName:="H:\" & fileName & " .xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close
tmpWs.Delete
End With
End Sub

Answer 2

Something like this
This code dumps the files to single sheet csv files under a directory held by strDir, "C:temp" in this example
Sub ParseCOlumn()
Dim X
Dim strDir As String
Dim strFName As String
Dim strText As String
Dim lngRow As Long
Dim lngStart As Long
Dim objFSO As Object
Dim objFSOFile As Object
Set objFSO = CreateObject("scripting.filesystemobject")
strDir = "C:\temp"
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
'test for first record not being "***"
lngStart = 1
If X(1) <> "***" Then
strFName = X(1)
lngStart = 2
End If
For lngRow = lngStart To UBound(X)
If X(lngRow) <> "***" Then
If Len(strText) > 0 Then
strText = strText & (vbNewLine & X(lngRow))
Else
strText = X(lngRow)
End If
Else
Set objFSOFile = objFSO.createtextfile(strDir & "\" & strFName & ".csv")
objFSOFile.write strText
objFSOFile.Close
strFName = X(lngRow + 1)
lngRow = lngRow + 1
strText = vbNullString
End If
Next
'dump last record
If X(UBound(X)) <> "***" Then
Set objFSOFile = objFSO.createtextfile(strDir & "\" & strFName & ".csv")
objFSOFile.write strText
End If
objFSOFile.Close
End Sub