Option Compare Database
Option Explicit

Dim ws As DAO.Workspace
Dim rsWrite As DAO.Recordset
Dim stringArray() As String
Dim randomStringCount As Long
Dim sectionTimes(1 To 4) As Date

Private Sub Form_Load()
    
    CreateStringArray
    SetupSortedTable
    
    ClearForm

End Sub

Private Sub btnCreateStrings_Click()

    If rsWrite Is Nothing Then
        SetupSortedTable ' if rerunning without closing
    End If
    
    ClearForm
    GenerateRandomStrings
End Sub

Private Sub btnSortStrings_Click()
    
    ClearForm
    
    CreateStringArray
    
    If rsWrite Is Nothing Then SetupSortedTable ' if rerunning without closing
    
    Dim startRun As Date
    Dim endRun As Date
    
    startRun = Now
    txtStartTime.SetFocus: txtStartTime.Text = Format(CDate(startRun), "mm/dd/yy hh:MM:ss")
        
    sectionTimes(1) = Now
    lblBusy.Caption = "Geting Strings": DoEvents
    GetStrings
    
    sectionTimes(2) = Now
    lblBusy.Caption = "Sorting Strings": DoEvents
    Quicksort stringArray, LBound(stringArray), UBound(stringArray)
    
    sectionTimes(3) = Now
    lblBusy.Caption = "Removing Duplicates": DoEvents
    RemoveDuplicates
    
    sectionTimes(4) = Now
    lblBusy.Caption = "Writing Sorted": DoEvents
    WriteTheStrings
    
    endRun = Now
    lblBusy.Caption = "Done"
        
    txtEndTime.SetFocus: txtEndTime.Text = Format(CDate(endRun), "mm/dd/yy hh:MM:ss")
    txtDuration.SetFocus: txtDuration.Text = DateDiff("s", startRun, endRun)
    txtCount.SetFocus: Me.txtCount.Text = UBound(stringArray) - 1
    
    Debug.Print "Get Strings start " & Format(sectionTimes(1), "h:mm:ss")
    Debug.Print "Sort Strings start " & Format(sectionTimes(2), "h:mm:ss")
    Debug.Print "Remove Duplicates start " & Format(sectionTimes(3), "h:mm:ss")
    Debug.Print "Write Strings start " & Format(sectionTimes(4), "h:mm:ss")
    
End Sub

Private Sub CreateStringArray()

    ' create string array for sorting
    On Error Resume Next
        ' if there is already a tblRandom table get the count of records in it
        Dim rsCount As DAO.Recordset
        Set rsCount = CurrentDb.OpenRecordset("select count(TextString) from tblRandom", dbOpenDynaset)
        randomStringCount = rsCount(0)
        lblCreatedStringsCount.Caption = "There are " & randomStringCount & " random strings"
        rsCount.Close
        Set rsCount = Nothing
        
        ReDim stringArray((randomStringCount - 1))
    On Error GoTo 0

End Sub

Private Sub ClearForm()

    txtStartTime.SetFocus: txtStartTime.Text = ""
    txtEndTime.SetFocus: txtEndTime.Text = ""
    txtDuration.SetFocus: txtDuration.Text = ""
    txtCount.SetFocus: Me.txtCount.Text = ""

End Sub

Private Sub SetupSortedTable()

    ' set up the table
    Set ws = DBEngine.Workspaces(0)

    On Error Resume Next
    ' create the tblPrimes table
    CurrentDb.Execute "drop table tblSorted"
    CurrentDb.Execute "Create Table tblSorted (ID AUTOINCREMENT PRIMARY KEY, SortedString TEXT(150));"

    On Error GoTo 0
    ' create the recordset
    Set rsWrite = CurrentDb.OpenRecordset("tblSorted", dbOpenTable)   ' open the table to be written to
    
    DoEvents
End Sub

Private Sub GetStrings()

    ' get the strings into an array
    Dim rs As DAO.Recordset
    Dim arrayIndex As Long
    
    Set rs = CurrentDb.OpenRecordset("Select * from tblRandom", dbOpenForwardOnly)

    arrayIndex = 0
    Do While Not rs.EOF
        stringArray(arrayIndex) = rs(1)
        rs.MoveNext
        arrayIndex = arrayIndex + 1
    Loop
    
    rs.Close
    Set rs = Nothing
    
End Sub

Private Sub RemoveDuplicates()

    Dim arrayIndex As Long
    Dim removedCount As Long
    
    removedCount = 0
    For arrayIndex = UBound(stringArray) - 1 To 1 Step -1
        If stringArray(arrayIndex) = stringArray(arrayIndex - 1) Then
            ' this is a duplicate of the one above it, make this blank
            stringArray(arrayIndex) = ""
            removedCount = removedCount + 1
        End If
    
    Next arrayIndex
    
    If removedCount > 0 Then
        ' duplicates were found and blanked out - remove the blanks
        Dim tempArray() As String
        Dim tempArrayIndex As Long
        
        ' use a temp array to hold the new array with no duplicates
        ReDim tempArray((UBound(stringArray) - removedCount))
        
        For arrayIndex = 0 To UBound(stringArray) - 1
            If Len(stringArray(arrayIndex)) > 0 Then
                tempArray(tempArrayIndex) = stringArray(arrayIndex)
                tempArrayIndex = tempArrayIndex + 1
            End If
        
        Next arrayIndex
        
        ' assign it back to the main array variable while condencing the array
        ReDim stringArray((UBound(stringArray) - removedCount))
        stringArray = tempArray
       
    End If
   
End Sub

Sub Quicksort(vArray As Variant, arrLbound As Long, arrUbound As Long)

    ' Sorts a one-dimensional VBA array from smallest to largest
    ' using a very fast quicksort algorithm variant.
    ' from https://wellsr.com/vba/2018/excel/vba-quicksort-macro-to-sort-arrays-fast/
    
    Dim pivotVal As Variant
    Dim vSwap As Variant
    Dim tmpLow As Long
    Dim tmpHi As Long
    
    tmpLow = arrLbound
    tmpHi = arrUbound
    pivotVal = vArray((arrLbound + arrUbound) \ 2)
     
    While (tmpLow <= tmpHi)
       While (vArray(tmpLow) < pivotVal And tmpLow < arrUbound)
          tmpLow = tmpLow + 1
       Wend
      
       While (pivotVal < vArray(tmpHi) And tmpHi > arrLbound)
          tmpHi = tmpHi - 1
       Wend
     
       If (tmpLow <= tmpHi) Then
          vSwap = vArray(tmpLow)
          vArray(tmpLow) = vArray(tmpHi)
          vArray(tmpHi) = vSwap
          tmpLow = tmpLow + 1
          tmpHi = tmpHi - 1
       End If
    Wend
     
    If (arrLbound < tmpHi) Then Quicksort vArray, arrLbound, tmpHi
    If (tmpLow < arrUbound) Then Quicksort vArray, tmpLow, arrUbound
      
End Sub

Private Sub WriteTheStrings()

    Dim arrayIndex As Long
    
    ws.BeginTrans
    
    ' loop the sorted array and write it to a table
    For arrayIndex = 0 To UBound(stringArray) - 1
        
        rsWrite.AddNew
        rsWrite("SortedString") = stringArray(arrayIndex)
        rsWrite.Update
        
    Next arrayIndex

    ws.CommitTrans
    
    rsWrite.Close
    Set rsWrite = Nothing
    
    ws.Close
    Set ws = Nothing

End Sub

Public Sub GenerateRandomStrings()

    ' provided string generation code
    Dim db As DAO.Database
    Dim tdf As DAO.TableDef
    Dim rst As DAO.Recordset
    Dim varListSize As Variant
    Dim nListSize As Long
    Dim nRecord As Long
    Dim nChar As Integer
    Dim sChar As String
    Dim sText As String
    Dim nRand As Integer
    Set db = CurrentDb
    
    ' Delete tblRandom if it exists
    On Error Resume Next
    db.TableDefs.Delete "tblRandom"
    On Error GoTo 0
    DoEvents
    
    ' Re-create tblRandom and add the required fields
    Set tdf = db.CreateTableDef("tblRandom")
    DoEvents
    With tdf
        .Fields.Append .CreateField("ID", dbLong)
        .Fields("ID").Attributes = dbAutoIncrField
        .Fields.Append .CreateField("TextString", dbText, 255)
    End With
    db.TableDefs.Append tdf
    
    Set rst = db.OpenRecordset("tblRandom", dbOpenDynaset)
    
    ' get the desired list size
    varListSize = InputBox("Number of Elements", "Enter Number", 1000000) ' default 1,000,000 but can be changed
    If varListSize = "" Or varListSize <= 0 Or Not IsNumeric(varListSize) Then
        MsgBox "Exiting", vbOKOnly + vbInformation, "Invalid Selection"
        Exit Sub
    End If
    
    nListSize = Fix(varListSize)
    ' generate the random list
    Call Rnd(-1)     ' required along with Randomize
    Randomize 12345  ' set seed based on nRecord to ensure that the list of generated strings is always the same
    
    Me.lblCreatedStringsCount.Caption = "Creating " & nListSize & " strings": DoEvents
    
    ws.BeginTrans
    
    ' Outer loop
    For nRecord = 1 To nListSize
        sText = ""
        
        ' generate 8 random values between 0 and 26
        For nChar = 1 To 8
        
            nRand = Int(27 * Rnd())  ' Random number between 0 and 26
            
            If nChar = 1 And nRand = 0 Then
                nRand = (nRecord Mod 26) + 1  ' don't allow the first character to be a space
            End If
            
            ' Convert to character
            If nRand = 0 Then
                sChar = " "  ' if nRand = 0 then a space is generated
                Exit For     ' stop once a space is encountered
            Else
                sChar = Chr(96 + nRand)  ' Chr(97) = "a", Chr(98) = "b", etc.
            End If
            
            ' Build the string
            sText = sText & sChar
        Next nChar
        
        ' Write to the table
        rst.AddNew
        rst!TextString = sText
        rst.Update
        
    Next nRecord
    
    ws.CommitTrans
    
    rst.Close
    Set rst = Nothing
    Set tdf = Nothing
    Set db = Nothing
    
    Me.lblCreatedStringsCount.Caption = "Table of " & Format(nListSize, "#,##0") & " random strings created"
    
    randomStringCount = nListSize ' update the array size required
End Sub