Excel

Create Text Files With Any Delimiter

Ease of Use

Easy

Version tested with

2002 

Submitted by:

matthewspatrick

Description:

This Excel add-in allows you to turn any range on an Excel worksheet into a delimited text file, using any delimiter string (tab, comma, any other single character or combination of characters) you like. 

Discussion:

Typically, when we need to use Excel to create a delimited text file (for example, for uploading into another app), we set up the worksheet and then save it as a CSV file. However, sometimes we only need to save a portion of a worksheet, or we need to use a different delimiter than the comma (a semicolon perhaps, or maybe the pipe character). This add-in allows you to write just a portion of a worksheet to the text file, if needed, and it also allows you to specify the delimiter, the text qualifier (if any), and whether to include a "leading" and/or "trailing" instance of the delimiter on the record. 

Code:

instructions for use

			

The following code Is In the ThisWorkbook module: Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) ' remove item from menu Application.CommandBars("Worksheet Menu Bar").Controls("&Tools").Controls("Custom Delimited File") _ .Delete End Sub Private Sub Workbook_Open() Dim cb As CommandBar Dim cbp As CommandBarPopup Dim cbb As CommandBarButton ' add button under Tools to the Excel menu to execute the add-in Set cb = Application.CommandBars("Worksheet Menu Bar") Set cbp = cb.Controls("&Tools") Set cbb = cbp.Controls.Add(Type:=msoControlButton, Temporary:=True) With cbb .Caption = "Custom Delimited File" .BeginGroup = True .OnAction = "MakeFile" On Error Resume Next .FaceId = 3272 On Error Goto 0 End With Set cbp = Nothing Set cbb = Nothing Set cb = Nothing End Sub The following code Is In regular module 'Module1': Option Explicit Sub MakeFile() Dim rng As Range Dim NumR As Long Dim NumC As Long Dim CountR As Long Dim CountC As Long Dim Delim As String Dim Qual As String Dim Leading As Boolean Dim Trailing As Boolean Dim TheFile As String Dim fso As Object Dim ts As Object Dim LineStr As String UserForm1.Show ' if user cancels form, quit sub If UserForm1.cmdCancel.Cancel Then Unload UserForm1 MsgBox "Operation Canceled by user" Exit Sub End If ' get variable setting from UserForm With UserForm1 Set rng = Range(.reRange) NumR = rng.Rows.Count NumC = rng.Columns.Count Delim = IIf(.obCharacter, .tbDelimiter, Chr(9)) 'Chr(9) = tab Qual = .tbTextQualifier Leading = .ckLeadingDelimiter Trailing = .ckTrailingDelimiter TheFile = .tbCreateFile End With Unload UserForm1 ' create the text file Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.CreateTextFile(TheFile, True) ' loop through range to build text file records For CountR = 1 To NumR LineStr = IIf(Leading, Delim, "") For CountC = 1 To NumC If Not IsNumeric(rng.Cells(CountR, CountC)) And Not IsDate(rng.Cells(CountR, CountC)) Then LineStr = LineStr & Qual & rng.Cells(CountR, CountC) & Qual Else LineStr = LineStr & rng.Cells(CountR, CountC) End If LineStr = LineStr & IIf(CountC < NumC, Delim, "") Next LineStr = LineStr & IIf(Trailing, Delim, "") ts.WriteLine LineStr Next ' release memory from object variables ts.Close Set ts = Nothing Set fso = Nothing MsgBox "Done. File written to " & TheFile End Sub The following code Is In regular module 'sai_RetrieveSplitItem': ' Function based on post by Brad Yundt ' http://www.experts-exchange.com/Applications/MS_Office/Excel/Q_21221177.html Option Explicit Option Private Module Public Function RetrieveSplitItem(Text As String, Separator As String, Item As Variant, _ Optional CaseSen As Boolean = False) ' Returns a specified substring from a larger string (Text) separated by a specified ' character sequence (Separator) Dim X As Variant If CaseSen Then X = Split(Text, Separator, -1, vbBinaryCompare) Else X = Split(Text, Separator, -1, vbTextCompare) End If If IsNumeric(Item) And (Item < 1 Or Item > (UBound(X) + 1)) Then RetrieveSplitItem = CVErr(xlErrNA) ElseIf Not IsNumeric(Item) And Item <> "L" And Item <> "l" Then RetrieveSplitItem = CVErr(xlErrNA) Else If Item = "L" Or Item = "l" Then Item = UBound(X) + 1 RetrieveSplitItem = X(Item - 1) End If End Function The following code Is In the code module For UserForm1: Option Explicit Private Sub cbWorkbook_Change() Dim ws As Worksheet With Me .cbWorksheet.Clear If .cbWorkbook <> "" Then .cbWorksheet.Enabled = True .LabelWs.Enabled = True For Each ws In Workbooks(.cbWorkbook.Value).Worksheets .cbWorksheet.AddItem ws.Name Next Workbooks(.cbWorkbook.Value).Activate Else .cbWorksheet.Enabled = False .LabelWs.Enabled = False End If End With End Sub Private Sub cbWorksheet_Change() With Me .reRange = "" If .cbWorksheet <> "" Then .reRange.Enabled = True .LabelRng.Enabled = True Worksheets(.cbWorksheet.Value).Select Else .reRange.Enabled = False .LabelRng.Enabled = False End If End With End Sub Private Sub cmdCancel_Click() Me.Hide End Sub Private Sub cmdChange_Click() Dim ThePath With Me ThePath = Application.GetSaveAsFilename(.tbCreateFile, "Text Files (*.txt), *.txt", , _ "Save Text File to...") If ThePath <> False Then .tbCreateFile = ThePath End With End Sub Private Sub cmdGo_Click() Dim rng As Range With Me If .cbWorkbook = "" Then MsgBox "You must select a workbook", vbCritical, "Invalid Entry" Exit Sub ElseIf .cbWorksheet = "" Then MsgBox "You must select a worksheet", vbCritical, "Invalid Entry" Exit Sub ElseIf .reRange = "" Then MsgBox "You must select a range", vbCritical, "Invalid Entry" Exit Sub ElseIf .obCharacter And .tbDelimiter = "" Then MsgBox "You must enter a delimiter", vbCritical, "Invalid Entry" Exit Sub ElseIf .tbCreateFile = "" Then MsgBox "You must select a worksheet", vbCritical, "Invalid Entry" Exit Sub End If On Error Resume Next Set rng = Range(.reRange) If Err <> 0 Then Err.Clear MsgBox "The range you entered is invalid. Please change it.", vbCritical, "Invalid Entry" Exit Sub End If On Error Goto 0 ThisWorkbook.Worksheets("Sheet1").Range("cbWorkbook") = .cbWorkbook ThisWorkbook.Worksheets("Sheet1").Range("cbWorksheet") = .cbWorksheet ThisWorkbook.Worksheets("Sheet1").Range("reRange") = .reRange ThisWorkbook.Worksheets("Sheet1").Range("tbDelimiter") = .tbDelimiter ThisWorkbook.Worksheets("Sheet1").Range("tbTextQualifier") = .tbTextQualifier ThisWorkbook.Worksheets("Sheet1").Range("ckLeadingDelimiter") = .ckLeadingDelimiter ThisWorkbook.Worksheets("Sheet1").Range("ckTrailingDelimiter") = .ckTrailingDelimiter ThisWorkbook.Worksheets("Sheet1").Range("tbCreateFile") = .tbCreateFile ThisWorkbook.Worksheets("Sheet1").Range("obCharacter") = .obCharacter ThisWorkbook.Worksheets("Sheet1").Range("obTab") = .obTab ThisWorkbook.Save .cmdCancel.Cancel = False .Hide End With End Sub Private Sub cmdOpen_Click() Dim wb As Workbook Dim ThePath Dim WbName As String With Me ThePath = Application.GetOpenFilename("Excel Workbooks (*.xls), *.xls", , _ "Select Workbook to Open...", , False) If ThePath <> False Then WbName = RetrieveSplitItem(CStr(ThePath), "\", "L") On Error Resume Next Set wb = Workbooks(WbName) If Err <> 0 Then Err.Clear Workbooks.Open ThePath .cbWorkbook.AddItem WbName Else MsgBox "There is already an open workbook with the name '" & WbName & "'.", vbCritical End If .cbWorkbook = WbName On Error Goto 0 End If End With End Sub Private Sub obCharacter_Change() With Me If .obCharacter Then .tbDelimiter.Enabled = True End With End Sub Private Sub obTab_Change() With Me If .obTab Then .tbDelimiter.Enabled = False End With End Sub Private Sub UserForm_Initialize() Dim wb As Workbook With Me .cmdCancel.Cancel = True .cbWorkbook.Clear For Each wb In Workbooks .cbWorkbook.AddItem wb.Name Next .cbWorksheet.Clear .cbWorksheet.Enabled = False .LabelWs.Enabled = False .reRange.Enabled = False .LabelRng.Enabled = False On Error Resume Next If Err <> 0 Then Err.Clear Else .cbWorkbook = ThisWorkbook.Worksheets("Sheet1").Range("cbWorkbook") cbWorksheet_Change .cbWorksheet = ThisWorkbook.Worksheets("Sheet1").Range("cbWorksheet") .reRange = ThisWorkbook.Worksheets("Sheet1").Range("reRange") End If On Error Goto 0 .tbDelimiter = ThisWorkbook.Worksheets("Sheet1").Range("tbDelimiter") .tbTextQualifier = ThisWorkbook.Worksheets("Sheet1").Range("tbTextQualifier") .ckLeadingDelimiter = ThisWorkbook.Worksheets("Sheet1").Range("ckLeadingDelimiter") .ckTrailingDelimiter = ThisWorkbook.Worksheets("Sheet1").Range("ckTrailingDelimiter") .tbCreateFile = ThisWorkbook.Worksheets("Sheet1").Range("tbCreateFile") .obCharacter = ThisWorkbook.Worksheets("Sheet1").Range("obCharacter") .obTab = ThisWorkbook.Worksheets("Sheet1").Range("obTab") End With End Sub

How to use:

  1. Download the sample file to your computer
  2. Open Excel
  3. Select Tools|Add-Ins from the menu
  4. Check the box for 'Custom Delimiter Export Add-In'. If you do not see it among the choices, click Browse, and navigate to the file CustomDelimterExport.xla
  5. To use the add-in, invoke the process by selecting Tools > Custom Delimited File, and use the form to enter your choices
 

Test the code:

  1. Open a workbook that has data you would like to export to a delimited text file
  2. Select Tools > Custom Delimited File from the menu
  3. Use the form controls to select the workbook, worksheet, range, delimiter, etc.
  4. Click Go!
  5. Open the resulting text file to see if the add-in rendered the file correctly
 

Sample File:

CustomDelimiterExport.zip 28.24KB 

Approved by mdmackillop


This entry has been viewed 362 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2014 VBA Express