Export to a fixed width textfile

 1999-10-13    Import & Export    0    103

This macro exports the visible text from a worksheet range to a fixed width textfile:

Sub ExportRangeAsFixedWidthText(SourceRange As Range, _
    Optional TargetFile As String = vbNullString)
' Exports the data in SourceRange to TargetFile in fixed-width format
' Uses the column widths in SourceRange as column widths
' Will append data to TargetFile if it already exists
' Example:
' ExportRangeAsFixedWidthText Selection
' ExportRangeAsFixedWidthText Worksheets("ExportSheet").Range("A1:E100"), _
    "C:\FolderName\FixedWidthText.txt"

Dim ColWidth As Integer, eCount As Long, r As Long, c As Long
Dim fn As Integer, strLine As String, strTemp As String
Dim blnShowTargetFile As Boolean
    ' validate the input data if necessary
    If SourceRange Is Nothing Then Exit Sub
    If SourceRange.Areas.Count > 1 Then Exit Sub
    If Application.WorksheetFunction.CountA(SourceRange) = 0 Then Exit Sub

    blnShowTargetFile = False
    If Len(TargetFile) < 6 Then
        blnShowTargetFile = True
        If Len(ThisWorkbook.Path) > 0 Then
            TargetFile = ThisWorkbook.Path
        Else
            TargetFile = CurDir
        End If
        strTemp = ThisWorkbook.Name
        c = InStrRev(strTemp, ".")
        If c > 1 Then
            strTemp = Left(strTemp, c - 1)
        End If
        TargetFile = TargetFile & Application.PathSeparator & strTemp & "_"
        strTemp = Replace(SourceRange.Address(False, False, xlA1), ":", vbNullString)
        TargetFile = TargetFile & strTemp & ".txt"
    End If

    ' perform export
    eCount = 0
    On Error GoTo NotAbleToExport
    fn = FreeFile
    Open TargetFile For Append As #fn ' open textfile for new input
    On Error GoTo 0

    ' start writing the fixed-width textfile
    With SourceRange
        For r = 1 To .Rows.Count
            If r Mod 25 = 0 Then
                Application.StatusBar = "Writing fixed-width textfile " & Format(r / .Rows.Count, "0 %")
            End If
            strLine = vbNullString
            For c = 1 To .Columns.Count
                ColWidth = CInt(.Columns(c).ColumnWidth + 0.5) + 1
                strTemp = vbNullString
                On Error Resume Next
                strTemp = .Cells(r, c).Text ' optionally use .Value
                On Error GoTo 0
                ' create fixed-width string
                If Len(strTemp) >= ColWidth Then
                    eCount = eCount + 1
                    If IsNumeric(strTemp) Then
                        strTemp = Space(ColWidth - 1)
                        strTemp = Replace(strTemp, " ", "#") ' show values as ####
                        strTemp = strTemp & " "
                    Else
                        strTemp = Left(strTemp, ColWidth - 1) & " " ' cut strings
                    End If
                Else
                    If IsNumeric(strTemp) Then
                        strTemp = Space(ColWidth - Len(strTemp) - 1) & strTemp & " " ' right align values
                    Else
                        strTemp = strTemp & Space(ColWidth - Len(strTemp)) ' left align text
                    End If
                End If
                strLine = strLine & strTemp
            Next c
            Print #fn, strLine
        Next r
    End With
    Close #fn ' close the textfile
    Application.StatusBar = False
    If eCount > 0 Then
        MsgBox eCount & " errors encountered during export, check datalength/columnwidth", _
            vbExclamation, "Export range to textfile"
    End If
    If blnShowTargetFile Then
        MsgBox "The result is saved in this file:" & vbLf & _
            TargetFile, vbInformation, "Export Fixed Width Text"
    End If
    Exit Sub

NotAbleToExport:
    MsgBox "Unable to connect to the file " & TargetFile, vbInformation, "Export Failed"
End Sub
This macro uses the macro above to export the selected cells to a fixed width textfile:

Sub ExportSelectedCellsAsFixedWidthText()
Dim SourceRange As Range
    On Error Resume Next
    Set SourceRange = Selection
    On Error GoTo 0
    If SourceRange Is Nothing Then Exit Sub
    If SourceRange.Columns.Count = ActiveSheet.Columns.Count Then Exit Sub
    If SourceRange.Rows.Count = ActiveSheet.Rows.Count Then Exit Sub

    ExportRangeAsFixedWidthText SourceRange
    Set SourceRange = Nothing
End Sub


Leave a comment:

Your comment will only be published after it has been moderated and found spam free.
Your e-mail address will only be used to display your Gravatar.