Question

我有一个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

Answer 1

只要提出一个可行的解决方案，肯定不是一个好的解决方案

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

像这样的东西

此代码将文件转储到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

分隔符后拆分ExcelSheet

2 个答案: