Сплит ExcelSheet после разделителя

У меня есть файл Excel, в первом листе у меня на column A какой-то текст, разделенный разделителем, вот так:

 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 

Мне нравится разделить содержимое после разделителя *** и поместить каждую часть в отдельный файл только с одним листом. Имя файлов должно быть первой строкой каждого раздела. Мне нужно копировать с форматированием, цветами и т. Д.

Это функция, но не копирование форматирования …

 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 

Просто выдайте работоспособное решение, конечно, не очень хорошее

 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 

Что-то вроде этого

Этот код выгружает файлы в файлы csv с одним листом в каталоге, strDir , «C: temp» в этом примере

 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 
Давайте будем гением компьютера.