Export to a delimited textfiles
1999-10-13 Import & Export 2 302
This macro exports the values or formulas from a worksheet range to a delimited text file:
Sub ExportRangeAsDelimitedText(SourceWB As String, _ SourceWS As String, SourceAddress As String, _ TargetFile As String, SepChar As String, SaveValues As Boolean, _ ExportLocalFormulas As Boolean, AppendToFile As Boolean) ' Exports the data in Workbooks(SourceWB).Worksheets(SourceWS).Range(SourceAddress) to ' the textfile TargetFile in CSV format, uses SepChar as column delimiter ' Example: ' ExportRangeAsDelimitedText ThisWorkbook.Name, "ExportSheet", "A3:E23", _ "C:\FolderName\DelimitedText.txt", ";", True, True, False Dim SourceRange As Range, SC As String * 1 Dim A As Integer, 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 If UCase(SepChar) = "TAB" Or UCase(SepChar) = "T" Then SC = Chr(9) Else SC = Left(SepChar, 1) End If ' perform export 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 character-separated 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 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 LineString = LineString & tLine & SC Next c pror = pror + 1 If pror Mod 50 = 0 Then Application.StatusBar = "Writing delimited textfile " & _ Format(pror / totr, "0 %") & "..." End If If Len(LineString) > 1 Then LineString = Left(LineString, Len(LineString) - 1) 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 End Sub