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