BinaryInsert
03.05.2018 15:00:45
Peter(silie)
habe einen BinaryInsert Sub geschrieben
(eigentlich zwei wegen Ascending und Descending)
Den habe ich jetzt 25 mal durchlaufen lassen
und dabei eine durschnittliche Zeit von 0,00994 Sekunden gehabt,
bei 3662 Array Elementen.
Da dies mein erster BinaryInsert für VBA ist, bin ich natürlich
an Verbesserungsvorschlägen interessiert!
Hier die Codes:
Private Sub BinaryInsertAscending(ByVal value_ As Variant, _
ByRef source As Variant, _
ByVal low As Long, _
ByVal high As Long)
Dim ref As Variant: ref = low + ((high - low) \ 2)
If value_ > source(high) Then
ReDim Preserve source(LBound(source) To UBound(source) + 1)
source(UBound(source)) = value_
Exit Sub
End If
If value_ = high Then Exit Sub
If value_ source(ref) Then
BinaryInsertAscending value_, source, ref + 1, high
Exit Sub
End If
End Sub
Private Sub BinaryInsertDescending(ByVal value_ As Variant, _
ByRef source As Variant, _
ByVal low As Long, _
ByVal high As Long)
Dim ref As Variant: ref = low + ((high - low) \ 2)
If value_ source(low) Then
ReDim Preserve source(LBound(source) To UBound(source) + 1)
PushBack source
source(LBound(source)) = value_
Exit Sub
End If
If low >= high Then Exit Sub
If value_ > source(ref) Then
BinaryInsertDescending value_, source, low, ref - 1
Exit Sub
End If
If value_ Der test sub:
Sub test()
Dim a As Variant
Dim b As Double
Dim bb As Double
Dim itm As Variant
Dim i As Long
Dim ttl As Double
Dim l As Double
Dim h As Double
l = 1
h = 0
For i = 1 To 25
itm = 190000000 + i
Debug.Print "Running Test Number: " & i
b = Round(Timer_.MicroTimer, 4)
a = Split(Join(Application.Transpose(frm_BoO.cb_DatensatzRef.list), ";"), ";")
Debug.Print "Current Array Length: " & UBound(a)
Debug.Print "Inserting : " & itm
BinaryInsertDescending CStr(itm), a, LBound(a), UBound(a)
Debug.Print "New Array Length: " & UBound(a)
bb = Round(Timer_.MicroTimer - b, 4)
Debug.Print "Time Elapsed (s): " & bb
ttl = ttl + bb
If l > bb Then l = bb
If h Das Timer_ Modul:
#If VBA7 Then
Private Declare PtrSafe Function getFrequency Lib "kernel32" Alias _
"QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare PtrSafe Function getTickCount Lib "kernel32" Alias _
"QueryPerformanceCounter" (cyTickCount As Currency) As Long
#Else
Private Declare Function getFrequency Lib "kernel32" Alias _
"QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare Function getTickCount Lib "kernel32" Alias _
"QueryPerformanceCounter" (cyTickCount As Currency) As Long
#End If
Public Function MicroTimer() As Double
' returns seconds
' uses Windows API calls to the high resolution timer
Dim cyTicks1 As Currency
Dim cyTicks2 As Currency
Static cyFrequency As Currency
MicroTimer = 0
' get frequency
If cyFrequency = 0 Then getFrequency cyFrequency
' get ticks
getTickCount cyTicks1
getTickCount cyTicks2
If cyTicks2 Direktfenster nach test:
Running Test Number: 1
Current Array Length: 3662
Inserting : 190000001
New Array Length: 3663
Time Elapsed (s): 0,0263
Running Test Number: 2
Current Array Length: 3662
Inserting : 190000002
New Array Length: 3663
Time Elapsed (s): 0,0174
Running Test Number: 3
Current Array Length: 3662
Inserting : 190000003
New Array Length: 3663
Time Elapsed (s): 0,0124
Running Test Number: 4
Current Array Length: 3662
Inserting : 190000004
New Array Length: 3663
Time Elapsed (s): 0,0072
Running Test Number: 5
Current Array Length: 3662
Inserting : 190000005
New Array Length: 3663
Time Elapsed (s): 0,0086
Running Test Number: 6
Current Array Length: 3662
Inserting : 190000006
New Array Length: 3663
Time Elapsed (s): 0,0148
Running Test Number: 7
Current Array Length: 3662
Inserting : 190000007
New Array Length: 3663
Time Elapsed (s): 0,0102
Running Test Number: 8
Current Array Length: 3662
Inserting : 190000008
New Array Length: 3663
Time Elapsed (s): 0,0077
Running Test Number: 9
Current Array Length: 3662
Inserting : 190000009
New Array Length: 3663
Time Elapsed (s): 0,0084
Running Test Number: 10
Current Array Length: 3662
Inserting : 190000010
New Array Length: 3663
Time Elapsed (s): 0,0083
Running Test Number: 11
Current Array Length: 3662
Inserting : 190000011
New Array Length: 3663
Time Elapsed (s): 0,008
Running Test Number: 12
Current Array Length: 3662
Inserting : 190000012
New Array Length: 3663
Time Elapsed (s): 0,0079
Running Test Number: 13
Current Array Length: 3662
Inserting : 190000013
New Array Length: 3663
Time Elapsed (s): 0,0079
Running Test Number: 14
Current Array Length: 3662
Inserting : 190000014
New Array Length: 3663
Time Elapsed (s): 0,0083
Running Test Number: 15
Current Array Length: 3662
Inserting : 190000015
New Array Length: 3663
Time Elapsed (s): 0,0143
Running Test Number: 16
Current Array Length: 3662
Inserting : 190000016
New Array Length: 3663
Time Elapsed (s): 0,0087
Running Test Number: 17
Current Array Length: 3662
Inserting : 190000017
New Array Length: 3663
Time Elapsed (s): 0,0074
Running Test Number: 18
Current Array Length: 3662
Inserting : 190000018
New Array Length: 3663
Time Elapsed (s): 0,0077
Running Test Number: 19
Current Array Length: 3662
Inserting : 190000019
New Array Length: 3663
Time Elapsed (s): 0,0073
Running Test Number: 20
Current Array Length: 3662
Inserting : 190000020
New Array Length: 3663
Time Elapsed (s): 0,0086
Running Test Number: 21
Current Array Length: 3662
Inserting : 190000021
New Array Length: 3663
Time Elapsed (s): 0,0088
Running Test Number: 22
Current Array Length: 3662
Inserting : 190000022
New Array Length: 3663
Time Elapsed (s): 0,0079
Running Test Number: 23
Current Array Length: 3662
Inserting : 190000023
New Array Length: 3663
Time Elapsed (s): 0,0085
Running Test Number: 24
Current Array Length: 3662
Inserting : 190000024
New Array Length: 3663
Time Elapsed (s): 0,0077
Running Test Number: 25
Current Array Length: 3662
Inserting : 190000025
New Array Length: 3663
Time Elapsed (s): 0,0082
Average Time in 25 Runs: 0,00994
Alltime Low: 0,0072
Alltime High: 0,0263