VBA help to split excel export into different text files

CKellerSID

New Member
Joined
Jan 22, 2015
Messages
8
I am using the code from this page: Exporting And Importing Text Into Excel to export an Excel worksheet to a certain format so I can import into another program.

I found the other program can only import 50 lines at at time (not counting the first and second line). So I want to export the excel worksheet into different text files breaking with the count of the rows =50 and save them with a "2", "3" etc at the end of the file names. Also each file must start with the same first and second lines which I have saved in the code as FirstLine and SecondLine

I did some editing on the code that I found and this is what I am currently using. The part I need help with is enclosed by '========================= lines

Thank you.


Code:
 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ExportToTextFile
' This exports a sheet or range to a text file, using a
' user-defined separator character.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportToTextFile(FName As String, _
    Sep As String, SelectionOnly As Boolean, _
    AppendData As Boolean)

'from http://www.cpearson.com/excel/ImpText.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Requirements:
'ask user for directory to store the files.
' Export data enclosed by double quotes and separated by commas.
' The first line and second lines do not need to be enclosed by double quotes but must be separated by commas
' The first line and second lines do not need a comma at the end.
'save file as .txt file
'the text files can only contain 50 lines

Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Dim dirName As String
Dim NumEnd As String
Dim FirstLine As String
Dim SecondLine As String


Quote = Chr(34)
comma = Chr(44)
Sep = Chr(34) & Chr(44)
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile


If SelectionOnly = True Then
    With Selection
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
Else
    With ActiveSheet.UsedRange
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
End If


If AppendData = True Then
    Open FName For Append Access Write As #FNum
Else
    Open FName For Output Access Write As #FNum
End If


For RowNdx = StartRow To EndRow
    WholeLine = ""
    For ColNdx = StartCol To EndCol
    
        'if there is nothing in cell then put nothing in cellvalue
        If Cells(RowNdx, ColNdx).Value = "" Then
           CellValue = ""
        Else
           CellValue = Cells(RowNdx, ColNdx).Value
        End If
        
        'the first row doesn't need a comma at the end
        If RowNdx = 1 Then
            If Cells(RowNdx, ColNdx).Value = "" Then
                WholeLine = WholeLine
            Else
                WholeLine = WholeLine & CellValue
            End If
        End If
        
         'the second row doesn't need comma or quote at the end
        If RowNdx = 2 Then
            If Cells(RowNdx, ColNdx).Value = "" Then
                WholeLine = WholeLine
            Else
                If ColNdx = EndCol Then
                    WholeLine = WholeLine & CellValue
                Else
                    WholeLine = WholeLine & CellValue & comma
                End If
            End If
        End If
        
        If RowNdx > 2 Then
            If ColNdx = EndCol Then
                WholeLine = WholeLine & Quote & CellValue & Quote
            Else
                WholeLine = WholeLine & Quote & CellValue & Sep
            End If
        End If
    Next ColNdx


    If RowNdx = 1 Then
        WholeLine = WholeLine
        'the first and second line must repeat in all of the text files at the beginning
        FirstLine = WholeLine
    End If


    If RowNdx = 2 Then
        WholeLine = Trim(WholeLine)
        LastInLine = Right(WholeLine, Len(WholeLine) - 1)
        If LastInLine = "," Then
            WholeLine = Left(WholeLine, Len(WholeLine) - 1) ' remove the end comma
        Else
            WholeLine = WholeLine
        End If
        'the first and second line must repeat in all of the text files at the beginning
        SecondLine = WholeLine
    End If
    
    If RowNdx > 2 Then
       ' WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
        If LastInLine = "," Then
            WholeLine = Left(WholeLine, Len(WholeLine) - 1) ' remove the end comma
        Else
            WholeLine = WholeLine
        End If
    End If
    
    If RowNdx Mod 50 = 0 Then
        Print #FNum, WholeLine ' want the last line to go into the file that is completing
            '=================================================
            'start a new file - this is what I don't know how to do.
            '=================================================
            'make sure the file starts with First and second lines
        '   Print #FNum, FirstLine
        '   Print #FNum, SecondLine
            'then have the 51-60 go into the second file, the 101-150 go into a third file, etc.
    Else
        Print #FNum, WholeLine
    End If 'for If RowNdx Mod 50 = 0
            
Next RowNdx


EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum


statusbox = MsgBox("Export Completed", vbInformation)

End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END ExportTextFile
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DoTheExport
' This prompts the user for the FileName and the separtor
' character and then calls the ExportToTextFile procedure.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DoTheExport()
    Dim FileName As Variant
    Dim Sep As String
    Dim FolderDate As Date
    'FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Text Files (*.txt),*.txt")
    With Application.FileDialog(msoFileDialogFolderPicker)
    '
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox ("No Folder Selected.  Exiting out...")
            Exit Sub
        End If
        dirName = .SelectedItems(1)
    End With
    FileName = dirName & "\" & ActiveSheet.Name & "_" & Format(Date, "mmddyyy") & ".txt"
    
  
  'If FileName = False Then
        ''''''''''''''''''''''''''
        ' user cancelled, get out
        ''''''''''''''''''''''''''
        'Exit Sub
    'End If
    'Sep = Application.InputBox("Enter a separator character.", Type:=2)
    If Sep = vbNullString Then
        ''''''''''''''''''''''''''
        ' user cancelled, get out
        ''''''''''''''''''''''''''
        'Exit Sub
        Sep = ""
    End If
    Debug.Print "FileName: " & FileName, "Separator: " & Sep
    ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _
       SelectionOnly:=False, AppendData:=False
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' END DoTheExport
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Forum statistics

Threads
1,214,936
Messages
6,122,340
Members
449,079
Latest member
rocketslinger

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top