VBA
Módulo estándar
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: ' this code: ' 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 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 SubGoto 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 SubGoto 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 *******************************************************
‘ El código se generó con colores utilizando el complemento gratuito Color Code para Access
