Create text Files from every row in an Excel sprea

问题:

I need help creating separate text files from each row in an excel spread sheet called "worksheet". I want the text files to be named with content of Column A, with columns B-G being the content, preferably with a double hard return between each column in the text file, so each column will have a blank line in between them.

Is this possible? How would I go about it. thanks!

回答1:

@nutsch's answer is perfectly fine and should work 99.9% of the time. In the rare occasion that FSO is not available, here's a version that doesn't have a dependency. As is, it does require that the source worksheet doesn't have any blank rows in the content section.

Sub SaveRowsAsCSV()

Dim wb As Excel.Workbook, wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim r As Long, c As Long

    Set wsSource = ThisWorkbook.Worksheets("worksheet")

    Application.DisplayAlerts = False 'will overwrite existing files without asking

    r = 1
    Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
        ThisWorkbook.Worksheets.Add ThisWorkbook.Worksheets(1)
        Set wsTemp = ThisWorkbook.Worksheets(1)

        For c = 2 To 7
            wsTemp.Cells((c - 1) * 2 - 1, 1).Value = wsSource.Cells(r, c).Value
        Next c

        wsTemp.Move
        Set wbNew = ActiveWorkbook
        Set wsTemp = wbNew.Worksheets(1)
        'wbNew.SaveAs wsSource.Cells(r, 1).Value & ".csv", xlCSV 'old way
        wbNew.SaveAs "textfile" & r & ".csv", xlCSV 'new way
        'you can try other file formats listed at http://msdn.microsoft.com/en-us/library/office/aa194915(v=office.10).aspx
        wbNew.Close
        ThisWorkbook.Activate
        r = r + 1
    Loop

    Application.DisplayAlerts = True

End Sub

回答2:

The attached VBA macro will do it, saving the txt files in C:\Temp\

Sub WriteTotxt()

Const forReading = 1, forAppending = 3, fsoForWriting = 2
Dim fs, objTextStream, sText As String
Dim lLastRow As Long, lRowLoop As Long, lLastCol As Long, lColLoop As Long

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

For lRowLoop = 1 To lLastRow

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set objTextStream = fs.opentextfile("c:\temp\" & Cells(lRowLoop, 1) & ".txt", fsoForWriting, True)

    sText = ""

    For lColLoop = 1 To 7
        sText = sText & Cells(lRowLoop, lColLoop) & Chr(10) & Chr(10)
    Next lColLoop

    objTextStream.writeline (Left(sText, Len(sText) - 1))


    objTextStream.Close
    Set objTextStream = Nothing
    Set fs = Nothing

Next lRowLoop

End Sub

回答3:

For the benefit of others, I sorted the problem out. I replaced "Chr(10) & Chr(10)" with "Chr(13) & Chr(10)" and it worked perfectly.

回答4:

I used the simple code below for saving my excel rows as a text file or many other format for quite a long time now and it has always worked for me.

Sub savemyrowsastext()
Dim x

For Each cell In Sheet1.Range("A1:A" & Sheet1.UsedRange.Rows.Count)
' you can change the sheet1 to your own choice
saveText = cell.Text
Open "C:\wamp\www\GeoPC_NG\sogistate\igala_land\" & saveText & ".php" For Output As #1
Print #1, cell.Offset(0, 1).Text
Close #1
For x = 1 To 3 ' Loop 3 times.
Beep ' Sound a tone.
Next x
Next cell
End Sub

Note:

1. Column A1 = file title
2. column B1 = file content
3. Until the last row containing text (ie empty rows)

in reverse order, if you want to make it like this;

1. Column A1 = file title
2. column A2 = file content
3. Until the last row containing text (ie empty rows), just change Print #1, cell.Offset(0, 1).Text to Print #1, cell.Offset(1, 0).Text

My folder location = C:\wamp\www\GeoPC_NG\kogistate\igala_land\
My file extension = .php, you can change the extension to your own choice (.txt, .htm & .csv etc) I included bip sound at the end of each saving to know if my work is going on
Dim x
For x = 1 To 3 ' Loop 3 times.
Beep ' Sound a tone.