Export to a fixed width textfile
1999-10-13 Import & Export 0 368
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