分隔符之后拆分ExcelSheet
我有一个Excel文件，在第一张表格中，我在column A上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
我喜欢在***分隔符之后分割内容，并将每个文件放在一个单独的文件中，只有一个表格。 文件的名称应该是每个部分的第一行。 我需要能够复制格式，颜色等
这是function，但不是复制格式…
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
只要给出一个可行的解决scheme，肯定不是一个好的
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
像这样的东西
此代码将文件转储到由strDir保存的目录下的单个csv文件，在本例中为“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