Как наиболее рационально подойти к разбиению очень большого текста на отдельные слова?

Option Explicit
 
Private Type HashItem
    Value   As String
    Next    As Long
    lCount  As Long
End Type
 
Private m_lHashCount    As Long
 
Private Sub Form_Load()
    Dim hash()      As HashItem
    Dim iFileNum    As Integer
    Dim sContent    As String
    Dim lPrevPos    As Long
    Dim lNextPos    As Long
    Dim lIndex      As Long
    Dim t           As Single
 
    t = Timer
    
    ' // Инициализация хеш таблицы
    ReDim hash(131071): m_lHashCount = 131072
    
    iFileNum = FreeFile
    
    ' // Чтение всего файла в строку
    Open App.Path & "\words.idl" For Binary As #iFileNum
    sContent = Space$(LOF(iFileNum))
    Get iFileNum, , sContent
    Close #iFileNum
    
    lPrevPos = 1
    
    ' // Проход по строкам и добавление записей в хеш таблицу
    Do
        
        lNextPos = InStr(lPrevPos, sContent, vbNewLine)
        If lNextPos = 0 Then lNextPos = Len(sContent)
        
        Add hash(), Mid$(sContent, lPrevPos, lNextPos - lPrevPos)
        lPrevPos = lNextPos + 2
        
    Loop Until lNextPos = Len(sContent)
    
    ' // Сортировка хеш таблицы
    qSort hash, 0, m_lHashCount - 1
    
    ' // Вывод в файл
    Open App.Path & "\words_sort_unique.idl" For Output As #iFileNum
    
    For lIndex = 0 To m_lHashCount - 1
        ' // Выводим только инициализированные данные
        If Len(hash(lIndex).Value) Then
            Print #iFileNum, hash(lIndex).Value, hash(lIndex).lCount
        End If
    Next
    
    Close #iFileNum
    
    MsgBox Format$(Timer - t, "0.000s")
    
    
End Sub
Private Sub qSort( _
            ByRef tHash() As HashItem, _
            ByVal lLow As Long, _
            ByVal lHigh As Long)
    Dim lI As Long, lJ As Long, lM As Long, tS As HashItem
    
    lI = lLow: lJ = lHigh: lM = (lI + lJ) \ 2
    
    Do Until lI > lJ
    
        Do While tHash(lI).Value < tHash(lM).Value
            lI = lI + 1
        Loop
        
        Do While tHash(lJ).Value > tHash(lM).Value
            lJ = lJ - 1
        Loop
        
        If lI <= lJ Then
        
            If lI = lM Then
                lM = lJ
            ElseIf lJ = lM Then
                lM = lI
            End If
            
            ' // Тут можно неплохо оптимизировать заменив копирование строк обменом
            tS = tHash(lJ)
            tHash(lJ) = tHash(lI)
            tHash(lI) = tS
            
            lI = lI + 1: lJ = lJ - 1
            
        End If
        
    Loop
    
    If lLow < lJ Then qSort tHash, lLow, lJ
    If lI < lHigh Then qSort tHash, lI, lHigh
    
End Sub
 
Private Sub Add(Items() As HashItem, Value As String)
    Dim I   As Long
    Dim N   As Long
    
    I = CalcHash(Value)
    
    If Len(Items(I).Value) Then
        If StrComp(Items(I).Value, Value, vbTextCompare) = 0 Then
            Items(I).lCount = Items(I).lCount + 1
            Exit Sub
        End If
        Do While Items(I).Next
            I = Items(I).Next
            If StrComp(Items(I).Value, Value, vbTextCompare) = 0 Then
                ' // Увеличиваем кличество повторений
                Items(I).lCount = Items(I).lCount + 1
                Exit Sub
            End If
        Loop
        
        If m_lHashCount > UBound(Items) Then
            ReDim Preserve Items(m_lHashCount + 1000000)
        End If
 
        Items(m_lHashCount).Value = Value
        Items(I).Next = m_lHashCount
 
    Else: Items(I).Value = Value
    End If
    
    m_lHashCount = m_lHashCount + 1
    
End Sub
Private Function CalcHash(s As String) As Long
    Dim I   As Long
    Dim c   As Integer
    For I = 1 To Len(s)
        c = Asc(LCase(Mid$(s, I, 1)))
        If c = 0 Then Exit For
        CalcHash = (CalcHash * 11 + c) And &HFFFFFF
    Next
    CalcHash = CalcHash And &H1FFFF
End Function

Items(I).lCount = Items(I).lCount + 1

Private Type HashItem
    Value   As String
    Next    As Long
    lCount  As Long
End Type
 
Dim hash()      As HashItem