1

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

2 回答 2

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
于 2012-10-12T06:37:15.870 回答
1

像这样的东西

此代码将文件转储到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
于 2012-10-12T10:54:06.903 回答