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