Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
'Dim BV As New BedvitCOM.VBA
'==================================================================================================
Sub PRDX_SortRecur_WithInd(aV(), aI() As Long, LBnd&, UBnd&)
Dim i&, j&, n&, x, y
i = LBnd: j = UBnd: x = aV((LBnd + UBnd) \ 2)
Do
While (aV(i) < x): i = i + 1: Wend
While (x < aV(j)): j = j - 1: Wend
If (i <= j) Then
y = aV(i): aV(i) = aV(j): aV(j) = y
n = aI(i): aI(i) = aI(j): aI(j) = n
i = i + 1: j = j - 1
End If
Loop Until (i > j)
If (LBnd < j) Then PRDX_SortRecur_WithInd aV, aI, LBnd, j
If (i < UBnd) Then PRDX_SortRecur_WithInd aV, aI, i, UBnd
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function PRDX_Sort_Arr2D(a2D, Optional ByVal nCol& = 1) As Variant
Dim aNew, aVal(), aInd&(), r&, rr&, c&
r = UBound(a2D, 1)
ReDim aVal(r), aInd(r)
For r = 1 To UBound(aInd)
aInd(r) = r
aVal(r) = a2D(r, nCol)
Next r
PRDX_SortRecur_WithInd aVal, aInd, 1, UBound(aInd)
ReDim aNew(UBound(a2D, 1), UBound(a2D, 2)): r = 0
For r = 1 To UBound(a2D, 1)
rr = aInd(r)
For c = 1 To UBound(a2D, 2)
aNew(r, c) = a2D(rr, c)
Next c
Next r
PRDX_Sort_Arr2D = aNew
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
'==================================================================================================
Sub CreateArr2Col(aOut, nUniq&, nRepeats&, Optional UnSort As Boolean)
Dim n&, r&, p&
If UnSort Then
ReDim aOut(nUniq * (1 + nRepeats), 3) ' Key, Value, Sort(Optional Temp)
Else
ReDim aOut(nUniq * (1 + nRepeats), 2)
End If
For n = 1 To nUniq
r = r + 1
aOut(r, 1) = "Key_" & n
aOut(r, 2) = "Val_" & r
If UnSort Then aOut(r, 3) = Rnd()
For p = 1 To nRepeats
r = r + 1
aOut(r, 1) = aOut(r - 1, 1)
aOut(r, 2) = "Val_" & r
If UnSort Then aOut(r, 3) = Rnd()
Next p
Next n
If Not UnSort Then Exit Sub
aOut = PRDX_Sort_Arr2D(aOut, 3)
'BV.ArraySortV aOut, 3
ReDim Preserve aOut(UBound(aOut), 2)
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub Test_Add()
Dim dic As New Dictionary
Dim x, a, t!, r&
' UnSort ----------------------------------------
t = Timer
CreateArr2Col a, 50000, 100, True
Debug.Print Round(Timer - t, 2), "CreateArr(UnSort)" ' 14.3
t = Timer
For r = 1 To UBound(a, 1)
x = dic(a(r, 1))
Next r
Debug.Print Round(Timer - t, 2), "Test(UnSort)" ' 2.9
dic.RemoveAll
' Sort ------------------------------------------
t = Timer
CreateArr2Col a, 50000, 100
Debug.Print Round(Timer - t, 2), "CreateArr(Sort)" ' 2.6
t = Timer
For r = 1 To UBound(a, 1)
x = dic(a(r, 1))
Next r
Debug.Print Round(Timer - t, 2), "Test(Sort)" ' 0.5
End Sub
'==================================================================================================
Private Sub Test_Exists()
Dim dic As New Dictionary
Dim a, s$, t!, r&
' UnSort ----------------------------------------
t = Timer
CreateArr2Col a, 50000, 100, True
Debug.Print Round(Timer - t, 2), "CreateArr(UnSort)" ' 14.3
t = Timer
For r = 1 To UBound(a, 1)
s = a(r, 1)
If Not dic.Exists(s) Then dic.Add s, 0
Next r
Debug.Print Round(Timer - t, 2), "Test(UnSort)" ' 3.1
'Debug.Print UBound(a, 1)
dic.RemoveAll
' Sort ------------------------------------------
t = Timer
CreateArr2Col a, 50000, 100
Debug.Print Round(Timer - t, 2), "CreateArr(Sort)" ' 2.6
t = Timer
For r = 1 To UBound(a, 1)
s = a(r, 1)
If Not dic.Exists(s) Then dic.Add s, 0
Next r
Debug.Print Round(Timer - t, 2), "Test(Sort)" ' 0.7
'Debug.Print UBound(a, 1)
End Sub
'==================================================================================================
Private Sub Test_ResumeNext()
Dim dic As New Dictionary
Dim a, t!, r&
On Error Resume Next
' UnSort ----------------------------------------
t = Timer
CreateArr2Col a, 50000, 100, True
Debug.Print Round(Timer - t, 2), "CreateArr(UnSort)" ' 14.6
t = Timer
For r = 1 To UBound(a, 1)
dic.Add a(r, 1), 0
Next r
Debug.Print Round(Timer - t, 2), "Test(UnSort)" ' 6.7
'Debug.Print UBound(a, 1)
dic.RemoveAll
' Sort ------------------------------------------
t = Timer
CreateArr2Col a, 50000, 100
Debug.Print Round(Timer - t, 2), "CreateArr(Sort)" ' 2.5
t = Timer
For r = 1 To UBound(a, 1)
dic.Add a(r, 1), 0
Next r
Debug.Print Round(Timer - t, 2), "Test(Sort)" ' 4.2
'Debug.Print UBound(a, 1)
On Error GoTo 0
End Sub
'==================================================================================================
' Need BedVit.COM library: https://bedvit.ru/com/
Private Sub Test_Map()
Dim map As New BedvitCOM.UnorderedMap
Dim a, t!, r&
On Error Resume Next
' UnSort ----------------------------------------
t = Timer
CreateArr2Col a, 50000, 100, True
Debug.Print Round(Timer - t, 2), "CreateArr(UnSort)" ' 14.4
t = Timer
For r = 1 To UBound(a, 1)
map.Insert a(r, 1), 0
Next r
Debug.Print Round(Timer - t, 2), "Test(UnSort)" ' 1.6
'Debug.Print UBound(a, 1)
map.Clear
' Sort ------------------------------------------
t = Timer
CreateArr2Col a, 50000, 100
Debug.Print Round(Timer - t, 2), "CreateArr(Sort)" ' 2.5
t = Timer
For r = 1 To UBound(a, 1)
map.Insert a(r, 1), 0
Next r
Debug.Print Round(Timer - t, 2), "Test(Sort)" ' 1.4
'Debug.Print UBound(a, 1)
On Error GoTo 0
End Sub
'==================================================================================================
|
