Large Text File Split into multiple text files

ayazgreat

Well-known Member
Joined
Jan 19, 2008
Messages
1,151
Hi

I copied below code from a web site, but i run this macro on a text file of 4.2 million and type to split it into 600,000, it is giving an error "Out of Memory Procedure SplitTextFile. Could any body help to resolve it ?

Code:
Sub SplitTextFile()
'Splits a text or csv file into smaller files
'with a user defined number (max) of lines or
'rows. The new files get the original file
'name + a number (1, 2, 3 etc.).


Dim sFile As String  'Name of the original file
Dim sText As String  'The file text
Dim lStep As Long    'Max number of lines in the new files
Dim vX, vY           'Variant arrays. vX = input, vY = output
Dim iFile As Integer 'File number from Windows
Dim lCount As Long   'Counter
Dim lIncr As Long    'Number for file name
Dim lMax As Long     'Upper limit for loop
Dim lNb As Long      'Counter
Dim lSoFar As Long   'How far did we get?


On Error GoTo ErrorHandle


'Select a file
sFile = Application.GetOpenFilename()


'If the user cancelled
If sFile = "False" Then Exit Sub


'Ask the user for max number of lines per file. E.g. 65536
lStep = Application.InputBox("Max number of lines/rows?", Type:=1)


'Our arrays have zero as LBound, so we subtract 1
lStep = lStep - 1


'Read the file text to sText
sText = _
CreateObject("Scripting.FileSystemObject").OpenTextFile(sFile).ReadAll


'Put the text into the array vX. Linefeed chars (new
'line) will add a new row to the array.
'If linefeed doesn't work try:
''vX = Split(sText, vbCrLf)
'which is Carriage return–linefeed kombination
vX = Split(sText, vbLf)


'Free memory
sText = ""


'Now we start a loop that will run until all
'rows in the array have been read and saved
'into new files. The variable lSoFar keeps
'track of how far we are in vX.
Do While lSoFar < UBound(vX)
   'If the number of rows minus lSoFar is
   'bigger than max number of rows, the
   'array vY is dimensioned to max number
   'of rows.
   If UBound(vX) - lSoFar >= lStep Then
      ReDim vY(lStep)
      'lMax is set = last rownumber to be
      'copied to vY.
      lMax = lStep + lSoFar
   Else
      'Else we dimension vY to the number of
      'rows left.
      ReDim vY(UBound(vX) - lSoFar)
      'Last row to copy is last row in vX
      lMax = UBound(vX)
   End If
   
   lNb = 0
   'Now we copy the rows from vX to vY
   For lCount = lSoFar To lMax
      vY(lNb) = vX(lCount)
      lNb = lNb + 1
   Next
   
   'lSoFar keeps track of how far we got in vX
   lSoFar = lCount
   
   'Get a free file number
   iFile = FreeFile
   
   'Increment the number for the new file name
   lIncr = lIncr + 1
   
   'Save vY as a text file (.txt). It could also be a csv-file,
   'but then you need to replace txt with csv.
   Open sFile & "-" & lIncr & ".txt" For Output As #iFile
      'The Join function makes a text
      'string from the array elements.
      Print #iFile, Join$(vY, vbCrLf)
   Close #iFile
Loop


Erase vX
Erase vY


Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure SplitTextFile"
End Sub
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Thanks for your reply, but issue/problem is still same after Double and is still receiving error "Out of Memory Procedure SplitTextFile.

Would you please suggest a way to resolve it ?
 
Last edited:
Upvote 0
Possibly import it into another program, like Access, that can handle that many rows.
What is it that you need to ultimately do with all this data?
If it is a task that can be completed in Access, maybe keep it all in there.
Otherwise, you could export it from there to multiple Excel files.
 
Upvote 0
OP, try this macro:
Code:
Public Sub Split_Text_File()

    Dim FSO As Object
    Dim TSRead As Object, TSWrite As Object
    Dim inputFile As Variant, outputFile As String
    Dim part As Long, i As Long, n As Long, p As Long
    Dim maxRows As Long
    
    inputFile = Application.GetOpenFilename(Title:="Select a text file to be split into separate parts")
    If inputFile = False Then Exit Sub

    maxRows = Application.InputBox("Max number of lines/rows?", Type:=1)
    If maxRows = 0 Then Exit Sub
        
    ReDim outputLines(maxRows - 1) As String
    p = InStrRev(inputFile, ".")
    part = 0
    n = 0
        
    Set FSO = CreateObject("Scripting.FileSystemObject")
        
    Set TSRead = FSO.OpenTextFile(inputFile)
    
    While Not TSRead.AtEndOfStream
        outputLines(n) = TSRead.ReadLine
        n = n + 1
        If n = maxRows Then
            part = part + 1
            outputFile = Left(inputFile, p - 1) & " PART" & part & Mid(inputFile, p)
            Set TSWrite = FSO.CreateTextFile(outputFile, True)
            TSWrite.Write Join(outputLines, vbCrLf)
            TSWrite.Close
            ReDim outputLines(maxRows - 1) As String
            n = 0
        End If
    Wend
    
    TSRead.Close

    If n > 0 Then
        ReDim outputlines2(n - 1) As String
        For i = 0 To n - 1
            outputlines2(i) = outputLines(i)
        Next
        part = part + 1
        outputFile = Left(inputFile, p - 1) & " PART" & part & Mid(inputFile, p)
        Set TSWrite = FSO.CreateTextFile(outputFile, True)
        TSWrite.Write Join(outputlines2, vbCrLf)
        TSWrite.Close
    End If
    
    MsgBox "Done"
    
End Sub
 
Upvote 0
Amazing, This has worked out my problem
Thank you so much, further is it possible "One Enter"/empty row after last row in each file

OP, try this macro:
Code:
Public Sub Split_Text_File()

    Dim FSO As Object
    Dim TSRead As Object, TSWrite As Object
    Dim inputFile As Variant, outputFile As String
    Dim part As Long, i As Long, n As Long, p As Long
    Dim maxRows As Long
    
    inputFile = Application.GetOpenFilename(Title:="Select a text file to be split into separate parts")
    If inputFile = False Then Exit Sub

    maxRows = Application.InputBox("Max number of lines/rows?", Type:=1)
    If maxRows = 0 Then Exit Sub
        
    ReDim outputLines(maxRows - 1) As String
    p = InStrRev(inputFile, ".")
    part = 0
    n = 0
        
    Set FSO = CreateObject("Scripting.FileSystemObject")
        
    Set TSRead = FSO.OpenTextFile(inputFile)
    
    While Not TSRead.AtEndOfStream
        outputLines(n) = TSRead.ReadLine
        n = n + 1
        If n = maxRows Then
            part = part + 1
            outputFile = Left(inputFile, p - 1) & " PART" & part & Mid(inputFile, p)
            Set TSWrite = FSO.CreateTextFile(outputFile, True)
            TSWrite.Write Join(outputLines, vbCrLf)
            TSWrite.Close
            ReDim outputLines(maxRows - 1) As String
            n = 0
        End If
    Wend
    
    TSRead.Close

    If n > 0 Then
        ReDim outputlines2(n - 1) As String
        For i = 0 To n - 1
            outputlines2(i) = outputLines(i)
        Next
        part = part + 1
        outputFile = Left(inputFile, p - 1) & " PART" & part & Mid(inputFile, p)
        Set TSWrite = FSO.CreateTextFile(outputFile, True)
        TSWrite.Write Join(outputlines2, vbCrLf)
        TSWrite.Close
    End If
    
    MsgBox "Done"
    
End Sub
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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