Exporting Excel rows to text files

Question

There are a few solutions I've seen but they don't specifically do what i'm trying to.

What I need to be able to do:

• each row to create a new text file
• each cell is a new line in this text file
• the file name is the value in column 2
• the file extension ".nfo"
• the folder to be saved into is the value (an absolute path) in column 1
• loop from row 3 to the first null row

I would post code but I have no idea where to start. Does anyone have any ideas?

Answer 1

As an example, I used the answer from the link I posted in comments.
I put a simple loop inside that loops the range, creating a row in the text file for each value.

Then I call with from another sub (not something you have to do) from within a loop that loop through all the rows, and for each row, passes the range of all the used column in said row. This specific code requires you to add a reference to Microsoft Scripting Runtime.

Option Explicit

Sub SaveNfo()
Dim ws As Worksheet, rng As Range, LastColumn As Range, rngRow As Variant
Set ws = Worksheets(1)
Set rng = ws.Range("A3:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row) 'start on row 3, include all rows with a filepath

For Each rngRow In rng
    If Not rngRow = "" Then
        SaveTextToFile rngRow & rngRow.Offset(, 1), _
        ws.Range(rngRow.Offset(, 2), Cells(rngRow.Row, ws.Cells(rngRow.Row, ws.Columns.Count).End(xlToLeft).Column))
    End If
Next
End Sub

Private Sub SaveTextToFile(filePath As String, rng As Range)
    Dim cell As Variant
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim fileStream As TextStream
    ' Here the actual file is created and opened for write access
    Set fileStream = fso.CreateTextFile(filePath)
    ' Write something to the file
    For Each cell In rng
            fileStream.WriteLine cell
    Next
    ' Close it, so it is not locked anymore
    fileStream.Close
End Sub

If the file name column doesn't include .nfo you can add that in the code manually:

SaveTextToFile rngRow & rngRow.Offset(, 1), _ Becomes
SaveTextToFile rngRow & rngRow.Offset(, 1) & ".nfo", _

rngRow points to the "A" column, for the path.
rngRow.Offset(, 1) is then the "B" column, for the name.
rngRow.Offset(, 2) is then ofc "C", where we start looking for data to put in the file.

Or, if you want the really short version:

Sub SaveNfo()
Dim rngRow As Variant, cell As Variant, fso As Object, fileStream As Object
For Each rngRow In Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row)
    If Not rngRow = "" Then
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set fileStream = fso.CreateTextFile(rngRow & rngRow.Offset(, 1))
        For Each cell In Range(rngRow.Offset(, 2), Cells(rngRow.Row, Cells(rngRow.Row, Columns.Count).End(xlToLeft).Column))
            fileStream.WriteLine cell
        Next
        fileStream.Close
    End If
Next
End Sub

Answer 2

Export Rows to Text Files

• Copy the complete code into a standard module.
• Before running exportRowsToTextFiles, adjust the values in its constants section and the worksheet (e.g. Set ws = ThisWorkbook.Worksheets("Sheet1")).
• Uncomment the various Debug.Print lines to better understand how it works by monitoring the output in the Immediate window.

Option Explicit

Sub exportRowsToTextFiles()
    
    Const First As String = "A3" ' First Data Cell Address
    Const fCol As Long = 1 ' First Column
    Const fpCol As Long = 1 ' File Path Column
    Const fbnCol As Long = 2 ' File Base Name Column
    Const fExt As String = ".nfo" ' File Extension
    Const ccSep As String = vbLf ' Cell Contents Separator
    Dim pSep As String: pSep = Application.PathSeparator
    
    If ActiveSheet Is Nothing Then Exit Sub ' if run from an Add-in
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub ' if e.g. chart
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    Dim brrg As Range: Set brrg = refBottomRightRange(ws.Range(First))
    'Debug.Print "Bottom Right Range: " & brrg.Address
    
    Dim nerg As Range: Set nerg = refNonEmptyRange(brrg)
    If nerg Is Nothing Then Exit Sub
    'Debug.Print "Non-Empty Range:    " & nerg.Address
    
    Dim Data As Variant: Data = getRange(nerg)
    'Debug.Print "Data Array:", "Rows=" & UBound(Data, 1), _
        "Columns=" & UBound(Data, 2)

    Dim rDat As Variant: ReDim rDat(0 To UBound(Data, 2) - fCol)
    
    Dim FilePath As String
    Dim r As Long, c As Long, n As Long
    
    For r = 1 To UBound(Data, 1)
        If Len(Data(r, fpCol)) > 0 Then
            If Len(Data(r, fbnCol)) > 0 Then
                FilePath = Data(r, fpCol) & pSep & Data(r, fbnCol) & fExt
                'Debug.Print FilePath
                n = -1
                For c = fCol To UBound(Data, 2)
                    n = n + 1
                    rDat(n) = Data(r, c)
                    'Debug.Print r, c, n, rDat(n)
                Next c
            End If
        End If
        writeStringToFile FilePath, Join(rDat, ccSep)
    Next r
    
End Sub

Function refBottomRightRange( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    With FirstCell.Worksheet
        Set refBottomRightRange _
            = .Range(FirstCell(1), .Cells(.Rows.Count, .Columns.Count))
    End With
End Function
Sub refBottomRightRangeTEST()
    Dim FirstCell As Range: Set FirstCell = Range("C5")
    Dim rg As Range: Set rg = refBottomRightRange(FirstCell)
    If Not rg Is Nothing Then Debug.Print rg.Address
End Sub

Function refBottomRightResize( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    With FirstCell
        Set refBottomRightResize = .Resize(.Worksheet.Rows.Count - .Row + 1, _
            .Worksheet.Columns.Count - .Column + 1)
    End With
End Function
Sub refBottomRightResizeTEST()
    Dim FirstCell As Range: Set FirstCell = Range("C5")
    Dim rg As Range: Set rg = refBottomRightResize(FirstCell)
    If Not rg Is Nothing Then Debug.Print rg.Address
End Sub

Function refNonEmptyRange( _
    ByVal rg As Range) _
As Range
    If rg Is Nothing Then Exit Function
    Dim lCell As Range
    Set lCell = rg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If lCell Is Nothing Then Exit Function
    With rg.Resize(lCell.Row - rg.Row + 1)
        Set refNonEmptyRange = .Resize(, _
            .Find("*", , , , xlByColumns, xlPrevious).Column - .Column + 1)
    End With
End Function
Sub refNonEmptyRangeTEST()
    Dim irg As Range: Set irg = Range("C5:F10")
    Dim rg As Range: Set rg = refNonEmptyRange(irg)
    If Not rg Is Nothing Then Debug.Print rg.Address
End Sub

Function getRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    If rg.Rows.Count = 1 And rg.Columns.Count = 1 Then
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        getRange = Data
    Else
        getRange = rg.Value
    End If
End Function

Sub writeStringToFile( _
        ByVal FilePath As String, _
        ByVal FileText As String)
    On Error GoTo clearError ' if file path is invalid (folder doesn't exist)
    Dim FileNum As Long: FileNum = FreeFile
    Open FilePath For Output As #FileNum
    Print #FileNum, FileText
    Close #FileNum
ProcExit:
    Exit Sub
clearError:
    Resume ProcExit
End Sub