Exporting Excel rows to text files - excel

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

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

Answer 2

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