Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - 36. Algorytmy sortujące

tkuchta1 · Excel Expert Posty: 2270

Że na forum dzisiaj taki fascynujący dzień podzielę się z chętnymi moją dzisiejszą Excelową zajawką - mianowicie:
Dopadłem jakiś czas temu książeczkę Algorytmy B. Buczek w której (oprócz wielu innych ciekawych rzeczy ;-)

) znajduje sie rozdział poświecony Alg. Sortującym, których na forum (przynajmniej w części mi znanej) za wiele nie ma. Powyciągłem co ciekawsze i z testami umieściłem w załączniku.
Wraz z testami procedury sią trochu zmieniały więc mam nadzieję że za bardzo nie namąciłem :-)

Błędów nie zauważyłem ale jeżeli coś Wam wpadnie w oko (czy okno Immediate ;-)

) To piszcie.
Może ktoś coś u siebie wykorzysta.

Kod:

Option Explicit
Declare Function GetTickCount Lib "Kernel32" () As Long

Public tabl
Const ile As Long = 20

Sub Test()
Dim i As Long
Dim przed As String
Dim po As String

ReDim tabl(0 To ile, 1)
For i = 1 To ile
tabl(i, 1) = Int(Rnd * 100 + 1)
Next
For i = 1 To ile
przed = przed & tabl(i, 1) & " "
Next
'Call SortowaniePrzezWybieranie
Call SortowaniePrzezWstawianie
'Call SortowanieBabelkowe
'Call SortowanieSzybkie(1, ile)

For i = 1 To ile
po = po & tabl(i, 1) & " "
Next
Debug.Print przed & vbCr & po

End Sub

Sub SortowaniePrzezWybieranie()
Dim i As Long
Dim j As Long
Dim Amin
Dim Bmin
For i = 1 To ile - 1
Amin = tabl(i, 1)
Bmin = i
For j = i + 1 To ile
If tabl(j, 1) < Amin Then
Amin = tabl(j, 1)
Bmin = j
End If
Next
tabl(Bmin, 1) = tabl(i, 1)
tabl(i, 1) = Amin
Next
End Sub

Sub SortowaniePrzezWstawianie()
Dim i As Long
Dim j As Long
Dim Ai

For i = 1 To ile
Ai = tabl(i, 1)
tabl(0, 1) = Ai
j = i - 1
While tabl(j, 1) > Ai
tabl(j + 1, 1) = tabl(j, 1)
j = j - 1
Wend
tabl(j + 1, 1) = Ai
Next
End Sub

Sub SortowanieBabelkowe()
Dim i As Long
Dim j As Long
Dim temp
For i = 2 To ile
For j = ile To 2 Step -1
If tabl(j - 1, 1) > tabl(j, 1) Then
temp = tabl(j - 1, 1)
tabl(j - 1, 1) = tabl(j, 1)
tabl(j, 1) = temp
End If
Next
Next
End Sub

Sub SortowanieSzybkie(lewy, prawy)
Dim l As Long
Dim p As Long
Dim med
Dim temp

If lewy < prawy Then
l = lewy
p = prawy
med = tabl(l, 1)
Do
While tabl(l, 1) < med
l = l + 1
Wend
While tabl(p, 1) > med
p = p - 1
Wend
If l <= p Then
temp = tabl(l, 1)
tabl(l, 1) = tabl(p, 1)
tabl(p, 1) = temp
l = l + 1
p = p - 1
End If
Loop Until l >= p
Call SortowanieSzybkie(lewy, p)
Call SortowanieSzybkie(l, prawy)
End If
End Sub

Sub ZmierzCzasAPI()
Dim czas As Double
Dim pocz As Long

pocz = GetTickCount

Call Test

czas = (GetTickCount - pocz) / 1000
Debug.Print CStr(czas) & " sekund"

End Sub

' ile = 1000 ile = 10k ile = 100k ile = 1M
' Rnd * 1000 Rnd * 10k Rnd * 100k Rnd * 1M
'Sort.PrzezWybieranie 0,047 3,468
'Sort.PrzezWstawianie 0,047 6,187
'Sort.Babelkowe 0,172 18,375
'Sort.Szybkie(1, ile) 0,016 0,062 0,813 9,234 :))

Sub test2()
Dim i As Long
Dim przed As String
'ReDim tabl(0 To 20, 1)
'For i = 1 To 20
'tabl(i, 1) = Range("B" & i)
'Next
tabl = [B1:B20]

'Call SortowaniePrzezWybieranie
'Call SortowaniePrzezWstawianie
Call SortowanieBabelkowe
'Call SortowanieSzybkie(1, ile)

'For i = 1 To 20
'Range("C" & i) = tabl(i, 1)
'Next
[C1:C20] = tabl
End Sub

' tabl = [B1:B20] w pętli
' [C1:C20] = tabl
'Sort.PrzezWybieranie TAK :) TAK :)
'Sort.PrzezWstawianie byk TAK :)
'Sort.Babelkowe TAK :) TAK :)
'Sort.Szybkie(1, ile) TAK :) Tak :)

' byk: >Subscript out of range< dla tabl(0,1) - zakres Arkusza go nie posiada

Edit:
Winien jestem jednak trochu poprawek (załącznika nie zmieniam)
- W procedurach Test i Test2 tablica powinna być zadeklarowana jako ReDim tabl(1 To ile, 1) wyjątkiem jest stosowanie SortowaniePrzezWstawianie ReDim tabl(0 To ile, 1)
- W proc. SortowaniePrzezWybieranie zmienna "Bmin" przechowuje indeks sortowanego elementu tablicy powinna być typu Long (i lepiej byłoby ją nazwać iMin)
- Pomiary czasów wykoniania procedury Test odbywały się po wykomentowaniu pętli zbierających dane do zmiennej "przed" i "po" - na czas składa się utworzenie tablicy i jej sortowanie

Narazie Tyle :-)

Alg Sortujące.zip

Pobierz Plik ściągnięto 245 raz(y) 11.55 KB