Use VBA to convert a cell range to columned txt file - excel

Question

I still consider myself a newbie with VBA, and would appreciate any help. There is one thing I am wondering how to do...
I have a worksheet like below, with data starting at row 16. I have a known number of rows (num_rows). I would like to loop through each row. Where Code = "s" I would like data exported to a s.txt, and where Code = "e" I would like data exported to e.txt. Other codes appear in the Code column which can be ignored. The outputted file would have each row on a new line, but also have sufficient spaces to align the data into their columns still in the text file. Any pointers?
Row#
Code
Title
Name
Country
16
s
Mr
James Smith
Australia
17
s
Mr
Karl Burns
USA
18
e
Mrs
Sara Sid
England

Answer 1

Scan the file to determine the maximum width of each column. Then scan again writing each line out with the columns padded to the required width with spaces. Copying the data to an array first will reduce the run time if you have a lot of data. See CreateTextFile and Space
Option Explicit
Sub Macro1()
Const HEADER_ROW = 15
Const COL_SPC = 2 ' column spacing
Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
Dim iRow As Long, iLastRow As Long, iLastCol As Integer
Dim r As Long, c As Integer, s As String, n As Integer
Dim arWidth() As Integer, arData, arHeader
' extent of data
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
iLastCol = ws.Cells(HEADER_ROW, Columns.Count).End(xlToLeft).Column
arData = ws.Range(ws.Cells(HEADER_ROW + 1, 1), ws.Cells(iLastRow, iLastCol))
' max width of each col
ReDim arWidth(iLastCol)
ReDim arHeader(iLastCol)
For c = 1 To UBound(arData, 2)
s = ws.Cells(HEADER_ROW, c)
arWidth(c) = Len(s) ' initalise with header width
For r = 1 To UBound(arData, 1)
If Len(arData(r, c)) > arWidth(c) Then
arWidth(c) = Len(arData(r, c))
End If
Next
' add spacing
arWidth(c) = arWidth(c) + COL_SPC
' space out header
arHeader(c) = s & Space(arWidth(c) - Len(s))
Next
'Export Data
Dim FSO As Object, ts(2), sFileName(2) As String
Dim sPath As String
Dim sColB, msg As String
Set FSO = CreateObject("Scripting.FileSystemObject")
sPath = wb.Path & "\"
' create 2 text streams
n = 1
For Each sColB In Array("e", "s")
sFileName(n) = sColB & ".txt"
Set ts(n) = FSO.CreateTextFile(sPath & sFileName(n), True, True) ' overwrite,unicode
' print header
ts(n).WriteLine Join(arHeader, "")
n = n + 1
Next
' export data
For r = 1 To UBound(arData, 1)
n = 0
' choose text stream
sColB = LCase(Trim(arData(r, 2)))
If sColB = "e" Then n = 1
If sColB = "s" Then n = 2
' write out 1 line of text
If n > 0 Then
s = ""
For c = 1 To UBound(arData, 2)
' space out columns
s = s & arData(r, c) & Space(arWidth(c) - Len(arData(r, c)))
Next
ts(n).WriteLine (s)
'Debug.Print s
End If
Next
' close text streams
For n = 1 To 2
msg = msg & vbCrLf & sFileName(n)
ts(n).Close
Next
' finish
MsgBox "2 Files created in " & sPath & msg
End Sub