Skip to content

Commit f104aa6

Browse files
authored
Update ArrayFunctions.bas
Hey, I was looking for some array.bas to improve my projects and this is awesome! But I use a function to sort array that I came up with a long time ago that is way faster than the one here. As a thank you for this project, I'd like to contribute with the arraySorterSDim (for single dim arrays) and the ArraySorter (for two dim arrays) You can compare the performance with a simple test: Function getFaster() Dim myArr(5000) As Variant Dim m1Arr() As Variant Dim m2Arr() As Variant Dim t1 As Double Dim i As Double For i = 0 To 5000 myArr(i) = Rnd Next i t1 = Time m1Arr = ArraySort(myArr) Debug.Print "time for m1:", Time - t1 t1 = Time m2Arr = arraySorterSDim(myArr) Debug.Print "time for m2:", Time - t1 End Function Wich gave me: time for m1: 00:00:21 time for m2: 00:00:09
1 parent 6c982e2 commit f104aa6

File tree

1 file changed

+85
-0
lines changed

1 file changed

+85
-0
lines changed

ArrayFunctions.bas

Lines changed: 85 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -791,6 +791,91 @@ Public Function ArraySort(SourceArray As Variant) As Variant
791791

792792
End Function
793793

794+
'SORT AN ARRAY [SINGLE DIMENSION - FASTER]
795+
'in this method we consider the array begins at 0, empty positions will be on the begining of the final array
796+
Function arraySorterSDim(ByVal RecArray As Variant) As Variant
797+
Dim Menor As String
798+
Dim NewArray() As Variant
799+
Dim i As Double, j As Double
800+
Dim menorIndex As Double
801+
Dim NewArrayIndex() As Double
802+
Dim UsedIndex() As Double
803+
ReDim NewArrayIndex(UBound(RecArray))
804+
ReDim NewArray(UBound(RecArray))
805+
For i = 0 To UBound(NewArrayIndex)
806+
NewArrayIndex(i) = -1
807+
Next i
808+
UsedIndex = NewArrayIndex 'get the dimension
809+
For i = 0 To UBound(RecArray)
810+
Menor = ""
811+
menorIndex = -1
812+
For j = 0 To UBound(RecArray)
813+
If UsedIndex(j) = -1 Then
814+
If Menor = "" Then
815+
Menor = RecArray(j)
816+
menorIndex = j
817+
Else
818+
If RecArray(j) < Menor Then
819+
Menor = RecArray(j)
820+
menorIndex = j
821+
End If
822+
End If
823+
End If
824+
Next j
825+
UsedIndex(menorIndex) = 1
826+
NewArrayIndex(i) = menorIndex
827+
Next i
828+
For i = 0 To UBound(NewArrayIndex)
829+
NewArray(i) = RecArray(NewArrayIndex(i))
830+
'Debug.Print NewArray(i)
831+
Next i
832+
arraySorterSDim = NewArray
833+
End Function
834+
835+
'SORT AN ARRAY [2 DIM WITH ONE COL AS REFERENCE TO SORT (if you need two or more columns as reference,
836+
'you can make a dummy col concatenating other columns and use it as reference)
837+
Function ArraySorter(ByVal RecArray As Variant, Optional ByVal RefCol As Integer = 0) As Variant
838+
Dim Menor As String
839+
Dim NewArray() As Variant
840+
Dim i As Double, j As Double
841+
Dim menorIndex As Double
842+
Dim NewArrayIndex() As Double
843+
Dim UsedIndex() As Double
844+
ReDim NewArrayIndex(UBound(RecArray, 2))
845+
ReDim NewArray(UBound(RecArray), UBound(RecArray, 2))
846+
For i = 0 To UBound(NewArrayIndex)
847+
NewArrayIndex(i) = -1
848+
Next i
849+
UsedIndex = NewArrayIndex
850+
For i = 0 To UBound(RecArray, 2)
851+
Menor = ""
852+
menorIndex = -1
853+
For j = 0 To UBound(RecArray, 2)
854+
If UsedIndex(j) = -1 Then
855+
If Menor = "" Then
856+
Menor = RecArray(RefCol, j)
857+
menorIndex = j
858+
Else
859+
If RecArray(ColNumber, j) < Menor Then
860+
Menor = RecArray(ColNumber, j)
861+
menorIndex = j
862+
End If
863+
End If
864+
End If
865+
Next j
866+
UsedIndex(menorIndex) = 1
867+
NewArrayIndex(i) = menorIndex
868+
Next i
869+
For i = 0 To UBound(NewArrayIndex)
870+
For j = 0 To UBound(NewArray)
871+
NewArray(j, i) = RecArray(j, NewArrayIndex(i))
872+
Next j
873+
Next i
874+
ArraySorter = NewArray
875+
End Function
876+
877+
878+
794879
'CHANGES THE CONTENTS OF AN ARRAY BY REMOVING OR REPLACING EXISTING ELEMENTS AND/OR ADDING NEW ELEMENTS.
795880
Public Function ArraySplice(SourceArray As Variant, Where As Long, HowManyRemoved As Integer, ParamArray Element() As Variant) As Variant
796881

0 commit comments

Comments
 (0)