VBA to Export Range to Text files

[mgm05267]

Hi...
I have a table with 51 columns and 20 rows
First column will have text & rest 50 columns will have numbers.

50 text files to be created in such a way that each text file should contain 20 rows with 1st column & its corresponding column.

For Ex:
1st text file contains column A & B
2nd text file contains column A & C
3rd text file contains column A & D
& so on... till 50th column.

File names could be instance 1, instance 2... instance 50

I am using the code provided here http://www.vbaexpress.com/kb/getarticle.php?kb_id=805

But it creates only one file. But how to create multiple files like this...

Please help...

 

[mgm05267]

Anyone ...Please ....

 

[mgm05267]

Anyone ...Please ....

 

[Rick Rothstein]

Give this macro a try, but first change the constant assignments (the Const statements) to match your actual setup and needs...

Sub MakeTextFiles()
  Dim X As Long, Z As Long, FF As Long, TextOut As String
  Const OutputPath As String = "c:\temp\"   '<==Note the trailing backslash
  Const BaseFileName As String = "Instance_"
  Const StartColumn As Long = 2   'Assumed Column B
  Const StartRow As Long = 3      'Assumed Row 3
  For X = StartColumn + 1 To StartColumn + 50
    TextOut = ""
    For Z = StartRow To StartRow + 19
      TextOut = TextOut & Cells(Z, StartColumn).Value & " " & Cells(Z, X).Value & vbNewLine
    Next
    FF = FreeFile
    Open OutputPath & BaseFileName & (X - StartColumn) & ".txt" For Output As #FF
    Print #FF, TextOut
    Close #FF
  Next
End Sub

 

[mgm05267]

Hi Rick Rothstein,

Ultimate one....

You saved my day... Thanks a lot....

The code works real fine...

Now, I will work on the code to make it dynamic.. Like if there are more than 50 columns & 20 rows.....

Once again thanks a ton...

 

[Rick Rothstein]

Thanks a lot....

The code works real fine...

Now, I will work on the code to make it dynamic.. Like if there are more than 50 columns & 20 rows.....

Once again thanks a ton...

You are quite welcome. The only changes I think you will need to make is to declare a variable for the columns and rows and set them to one less then the total number of columns and rows. You had 51 columns, so replace the 50 in my code with the variable you declare for columns (and set it to one less than the total number of columns) and you had 20 rows, so replace the 19 in my code with the variable you declared for rows (and set it to one less than the total number of rows).

 

[msh03046]

Sorry to rehash an older thread, but I've used the code above with good results. Having said that, I've been trying to get it to bypass blank rows in my range of cells. As this is written the vbNewLine enters a carriage return even for empty cells, thereby putting a lot of unwanted blank lines in the text file. I tried several techniques with no joy. What would be the easiest way to add this functionality? Thank you!

 

[Rhodie72]

Sorry to rehash an older thread, but I've used the code above with good results. Having said that, I've been trying to get it to bypass blank rows in my range of cells. As this is written the vbNewLine enters a carriage return even for empty cells, thereby putting a lot of unwanted blank lines in the text file. I tried several techniques with no joy. What would be the easiest way to add this functionality? Thank you!

It needs to be fixed from the beginning by selecting the area with data and blank cells and then doing something like this:

WARNING this code will irevocably delete entire rows:

Sub Delete_Blanks()
'
' Delete_Blanks Macro
' Deletes blank rows in selection
'

'
    With Selection
        .SpecialCells(xlCellTypeBlanks).Select
        .EntireRow.Delete
    End With
    Application.CutCopyMode = False
End Sub

However, if you just want the data to shift upwards and delete empty cells...

Sub Delete_cells_up()
'
' Delete_cells_up Macro
' Deletes empty cells
'

'
    With Selection
        .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        .End(xlUp).Select
    End With
End Sub

 

[Rhodie72]

I noticed that there is a recurrent "ThisWorkbook.Worksheets("Sheet1")" through all your code. It would be a good idea to to make this shorter by aliasing it to something like...

Dim TW as Workbook, WkSht1 as Sheet
'  Instead of writing ThisWorkbook.Worksheets("Sheet1")
'  You write this:
    Set TW=ThisWorkbook
    Set WkSht1=Worksheets("Sheet1")
'Now you can use    TW.WkSht1 instead of ThisWorkbook.Worksheets("Sheet1")"

Here is the original code yopu posted elsewhere...

In this you Dimension variables on separate lines which is not needed, just put a comma between each

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, cbp As CommandBarPopup, 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()
'   Edited for you   
    Dim NumR As Long,Dim NumC As Long,CountR As Long, CountC As Long,
    Dim Delim As String, Qual As String, TheFile As String,LineStr As String
    Dim Rng As Range
    Dim fso As Object, ts As Object
    Dim Leading As Boolean, Trailing As Boolean
    
    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
[CODE=vba]
    
End Sub

The following code Is In regular module 'sai_RetrieveSplitItem':

' Function based on post by Brad Yundt
' Solved: Left Mid and Right | Experts Exchange

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
[/CODE]

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
        with ThisWorkbook.Worksheets("Sheet1")
                .Range("cbWorkbook") = .cbWorkbook
                .Range("cbWorksheet") = .cbWorksheet
                .Range("reRange") = .reRange
                .Range("tbDelimiter") = .tbDelimiter
                .Range("tbTextQualifier") = .tbTextQualifier
                .Range("ckLeadingDelimiter") = .ckLeadingDelimiter
                .Range("ckTrailingDelimiter") = .ckTrailingDelimiter
                .Range("tbCreateFile") = .tbCreateFile
                .Range("obCharacter") = .obCharacter
                .Range("obTab") = .obTab
        end with
        ThisWorkbook.Save
        .cmdCancel.Cancel = False
        .Hide
    End With
    
End Sub
 
Private Sub cmdOpen_Click()
    
    Dim wb As Workbook, ThePath, 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

Now the added portion that you said worked:

Sub MakeTextFiles()
  Dim X As Long, Z As Long, FF As Long, TextOut As String
  Const OutputPath As String = "c:\temp\"   '<==Note the trailing backslash
  Const BaseFileName As String = "Instance_"
  Const StartColumn As Long = 2   'Assumed Column B
  Const StartRow As Long = 3      'Assumed Row 3
  For X = StartColumn + 1 To StartColumn + 50
    TextOut = ""
    For Z = StartRow To StartRow + 19
      TextOut = TextOut & Cells(Z, StartColumn).Value & " " & Cells(Z, X).Value & vbNewLine
    Next
    FF = FreeFile
    Open OutputPath & BaseFileName & (X - StartColumn) & ".txt" For Output As #FF
    Print #FF, TextOut
    Close #FF
  Next
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

 

[Rhodie72]

Oh dear, this was misposted to wrong answer. Apologies