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

セパレーターの後でコンテンツを分割し、***各ピースを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

このようなもの

このコードは、この例では「C：temp」がcsv保持するディレクトリの下の単一シートファイルにファイルをダンプします。strDir

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 に答える