VBA
Standard module
Option Compare Database
' at top of module, set Option Compare [Database|Text] to Ignore Case
' otherwise, modify this code to convert case for comparing
Option Explicit 'variables must be declared
'*************** Code Start ***************************************************
' module: bas_Array_Sort_s4p
'
' Purpose : Pass a string array you want to sort -- it will be changed.
' 1- or 2-dimensional array
' Optionally, designate a column index to sort by
' Author : crystal (strive4peace)
' Code List: https://msaccessgurus.com/code.htm
' this code: https://msaccessgurus.com/VBA/Array_Sort2D.htm
' LICENSE :
' You may freely use and share this code, but not sell it.
' Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
'-------------------------------------------------------------------------------
' SortStringArray2D
'-------------------------------------------------------------------------------
Public Sub SortStringArray2D(ByRef psArray() As String _
,Optional ByVal piSortColumnIndex As Integer = -1 _
)
' Sort a string array by specified column
' 240520 strive4peace, ... 240714 stop if done
' based on bubble-sort code originally written by Brent Spaulding
' although designed for 2-dimensional arrays,
' this code also works to sort 1-dimensional arrays
' PARAMETERs
' psArray -- string array you want to sort
' 1 or 2 dimensions will be considered
' piSortColumnIndex is the column index (2nd dimension)
' in the array to sort by
' if not specified, will be by the first column
On Error GoTo Proc_Err
Dim asCurrentValue() As String
Dim iColumn As Integer _
,iColumn1 As Integer _
,iColumn2 As Integer _
,iRow As Integer _
,iRow1 As Integer _
,iRow2 As Integer _
,iRows As Integer _
,iLastRow As Integer _
,iCountSwap As Integer _
,sValue1 As String _
,sValue2 As String
iRow1 = LBound(psArray,1) 'first row
iRow2 = UBound(psArray,1) 'last row
iRows = iRow2 - iRow1 + 1 'calculate number of rows
iColumn1 = LBound(psArray,2) 'first column
iColumn2 = UBound(psArray,2) 'last column
iCountSwap = 0 'haven't swapped anything yet
If piSortColumnIndex < iColumn1 Then
'sort by first column if lower number specified
'default is -1
piSortColumnIndex = iColumn1
End If
If piSortColumnIndex > iColumn2 Then
'sort by last column if higher number specified
piSortColumnIndex = iColumn2
End If
'array with current values -- works with one-dimensional arrays too
ReDim asCurrentValue(iColumn1 To iColumn2)
'Bubble sort the array if more than 1 row
If iRows > 1 Then
'set the last row to compare
iLastRow = iRow2
'loop until last row is the first row
Do Until iLastRow = iRow1
'loop from first row to next to last row
For iRow = iRow1 To iLastRow - 1
'store current value and next value, in Sort Column
sValue1 = psArray(iRow,piSortColumnIndex)
sValue2 = psArray(iRow + 1,piSortColumnIndex)
'if current is greater than next, then swap them
If sValue1 > sValue2 Then
'save current value for each column in array
For iColumn = iColumn1 To iColumn2
asCurrentValue(iColumn) = psArray(iRow,iColumn)
Next iColumn
'swap value in each column
For iColumn = iColumn1 To iColumn2
'assign current values to next row values
psArray(iRow,iColumn) = psArray(iRow + 1,iColumn)
'assign next row values to saved values
psArray(iRow + 1,iColumn) = asCurrentValue(iColumn)
Next iColumn
'count how many swaps made for this pass
iCountSwap = iCountSwap + 1
End If 'values swapped
Next iRow
'stop the loop if no swaps were made
If Not iCountSwap > 0 Then
'all done!
Exit Do
End If
iLastRow = iLastRow - 1 'decrement last row
iCountSwap = 0 'reset swap counter
Loop ' Until iLastRow = iRow1
End If
Proc_Exit:
On Error GoTo 0 'reset
Exit Sub
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " SortStringArray2D"
Resume Proc_Exit
Resume
End Sub
Goto Top
'-------------------------------------------------------------------------------
' BubbleSort -- simple example
'-------------------------------------------------------------------------------
Public Sub BubbleSort(ByRef psArray() As String)
' 240714 strive4peace
' Sort a single dimension string array
' based on bubble-sort code originally written by Brent Spaulding
' PARAMETERs
' psArray -- string array to sort
On Error GoTo Proc_Err
Dim iRow As Integer _
,iRow1 As Integer _
,iRow2 As Integer _
,iRows As Integer _
,iLastRow As Integer _
,iCountSwap As Integer _
,sValue1 As String _
,sValue2 As String
iRow1 = LBound(psArray,1) 'first row
iRow2 = UBound(psArray,1) 'last row
iRows = iRow2 - iRow1 + 1 'calculate number of rows
iCountSwap = 0 'haven't swapped anything yet
'Bubble sort the array if more than 1 row
If iRows > 1 Then
'set the last row to compare
iLastRow = iRow2
'loop until last row is the first row
Do Until iLastRow = iRow1
'loop from first row to next to last row
For iRow = iRow1 To iLastRow - 1
'store current value and next value
sValue1 = psArray(iRow)
sValue2 = psArray(iRow + 1)
'if current value is greater than next, then swap values
If sValue1 > sValue2 Then
'set current row value = next value
psArray(iRow) = sValue2
'set next value = saved current value
psArray(iRow + 1) = sValue1
'count how many swaps made for this pass
iCountSwap = iCountSwap + 1
End If
Next iRow
'stop the loop if no swaps were made
If Not iCountSwap > 0 Then
'all done!
Exit Do
End If
iLastRow = iLastRow - 1 'decrement last row
iCountSwap = 0 'reset swap counter
Loop ' Until iLastRow = iRow1
End If
Proc_Exit:
On Error GoTo 0 'reset
Exit Sub
Proc_Err:
MsgBox Err.Description _
,, "ERROR " & Err.Number _
& " BubbleSort"
Resume Proc_Exit
Resume
End Sub
Goto Top
'-------------------------------------------------------------------------------
' testBubbleSort -- for testing
'-------------------------------------------------------------------------------
Sub testBubbleSort()
'270414 s4p, for testing
'make an array with string values
' write the original values, sort, then write final values
'CALLs
' BubbleSort
' WriteArray2Debug
Dim asArray() As String
'define test array
asArray = Split( _
"Title" _
& ",Subject" _
& ",Author" _
& ",Keywords" _
& ",Comments" _
& ",Last author" _
& ",Revision number" _
& ",Application name" _
& ",Manager" _
& ",Company" _
, ",")
Debug.Print "INITAL ARRAY"
Call WriteArray2Debug(asArray)
'sort the array
Call BubbleSort(asArray)
Debug.Print "SORTED ARRAY"
Call WriteArray2Debug(asArray)
End Sub
'-------------------------------------------------------------------------------
' WriteArray2Debug -- for testing
'-------------------------------------------------------------------------------
Public Sub WriteArray2Debug( _
ByRef psArray() As String _
,Optional pbShowIndex As Boolean = True)
'270414 s4p, for testing
' write values of a string array to the debug window
' PARAMETERs
' psArray -- string array
' pbShowIndex = true to show element index
Dim i As Integer
Debug.Print String(25, "-")
For i = LBound(psArray) To UBound(psArray)
If pbShowIndex Then
Debug.Print i; Tab(7);
End If
Debug.Print psArray(i)
Next i
Debug.Print String(25, "-")
End Sub
'*************** Code End *******************************************************
' Code was generated with colors using the free
Color Code add-in for Access
