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 396 times.

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