Export to a fixed-width textfile

This macro exports the values or formulas from a worksheet range to a fixed-width textfile:
Sub ExportRangeAsFixedText(SourceWB As String, _
    SourceWS As String, SourceAddress As String, _
    TargetFile As String, LeftAlign As Boolean, _
    SaveValues As Boolean, ExportLocalFormulas As Boolean, _
    AppendToFile As Boolean)
' Exports the data in Workbooks(SourceWB).Worksheets(SourceWS).Range(SourceAddress) to
' the textfile TargetFile in fixed-width format, 
' uses the column widths in SourceAddress as field lengths
' Example:     ExportRangeAsFixedText ThisWorkbook.Name, _
    "ExportSheet", "A3:E23", _
    "C:\FolderName\FixedWidthText.txt", False, True, True, False


Dim SourceRange As Range, A As Integer, aCount As Integer
Dim ColWidth As Integer, eCount As Long
Dim r As Long, c As Integer, totr As Long, pror As Long
Dim fn As Integer, LineString As String, tLine As String
    ' validate the input data if necessary
    Workbooks(SourceWB).Activate
    Worksheets(SourceWS).Activate
    If Application.WorksheetFunction.CountA(Range(SourceAddress)) = 0 Then Exit Sub
    If Not AppendToFile Then
        If Dir(TargetFile) <> "" Then
            On Error Resume Next
            Kill TargetFile
            On Error GoTo 0
            If Dir(TargetFile) <> "" Then
                MsgBox TargetFile & _
                    " already exists, rename, move or delete the file before you try again.", _
                    vbInformation, "Export range to textfile"
                Exit Sub
            End If
        End If
    End If
    
    ' perform export
    eCount = 0
    Set SourceRange = Range(SourceAddress)
    On Error GoTo NotAbleToExport
    fn = FreeFile
    Open TargetFile For Append As #fn ' open textfile for new input
    On Error GoTo 0
    ' determine the total number of rows to process
    totr = 0
    For A = 1 To SourceRange.Areas.Count
        totr = totr + SourceRange.Areas(A).Rows.Count
    Next A
    ' start writing the fixed-width textfile
    pror = 0
    For A = 1 To SourceRange.Areas.Count
        For r = 1 To SourceRange.Areas(A).Rows.Count
            LineString = ""
            For c = 1 To SourceRange.Areas(A).Columns.Count
                ColWidth = CInt(SourceRange.Areas(A).Columns(c).ColumnWidth)
                tLine = ""
                On Error Resume Next
                If SaveValues Then
                    tLine = SourceRange.Areas(A).Cells(r, c).Value
                Else
                    If ExportLocalFormulas Then
                        tLine = SourceRange.Areas(A).Cells(r, c).FormulaLocal
                    Else
                        tLine = SourceRange.Areas(A).Cells(r, c).Formula
                    End If
                End If
                On Error GoTo 0
                ' create fixed-width string
                If Len(tLine) > ColWidth Then
                    eCount = eCount + 1
                Else
                    If LeftAlign Then
                        tLine = tLine & Space(ColWidth - Len(tLine))
                    Else
                        tLine = Space(ColWidth - Len(tLine)) & tLine
                    End If
                End If
                LineString = LineString & tLine
            Next c
            pror = pror + 1
            If pror Mod 50 = 0 Then
                Application.StatusBar = "Writing fixed-width textfile " & _
                    Format(pror / totr, "0 %") & "..."
            End If
            If LineString = "" Then
                Print #fn,
            Else
                Print #fn, LineString
            End If
        Next r
    Next A
    Close #fn ' close the textfile
NotAbleToExport:
    Set SourceRange = Nothing
    Application.StatusBar = False
    If eCount > 0 Then
        MsgBox eCount & _
            " errors encountered during export, check datalength/columnwidth", _
            vbExclamation, "Export range to textfile"
    End If
End Sub
Document last updated 1999-10-13 12:50:53 Printerfriendly version