CODEWITHSUNDEEP
excelvba
Stuart
Stuart

Reputation: 39

Use VBA to convert a cell range to columned txt file

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

Upvotes: 0

Views: 133

Answers (1)

CDP1802
CDP1802

Reputation: 16357

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

Upvotes: 1

Related Questions