Метод быстрой сортировки

Код программы:

Option Explicit

Private Sub Label1_Click()

End Sub

Private Sub lblTime1_Click()

End Sub

Private Sub lblTime2_Click()

End Sub

Private Sub OKButton_Click()

Dim Array1() As Long, Array2() As Long

Dim i As Long

Dim Elements As Long, RElement As Long, Temp As Long

Dim Time1 As Date, Time2 As Date

Dim Msg As String

Dim r As Long

lblTime1.Caption = ""

' Проверка вводимых в форму данных

If Not IsNumeric(tbElements.Value) Then

MsgBox "Некорректные данные (нет элементов)", vbInformation

tbElements.SetFocus

Exit Sub

End If

Elements = Val(tbElements.Value)

If Elements < 1 Then

MsgBox "Некорректные данные (Нет элементов)", vbInformation

tbElements.SetFocus

Exit Sub

End If

' Формирование двух идентичных массивов

lblCurrentSort = "Создание массива..."

Me.Repaint

Randomize

ReDim Array1(1 To Elements, 0)

ReDim Array2(1 To Elements)

For i = 1 To Elements

Array1(i, 0) = CLng(Rnd * 100000)

Array2(i) = Array1(i, 0)

Next i

' Метод быстрой сортировки

If CheckBox1 Then

lblCurrentSort = " Метод быстрой сортировки... "

Me.Repaint

Time1 = Timer

Call MetodSort (Array2, LBound(Array1), UBound(Array1))

Time2 = Timer

lblTime1.Caption = Format(Time2 - Time1, "00.00") & " сек."

Me.Repaint

End If

' Сохранение отсортированных данных

Worksheets("Данные").Activate

Cells.Clear

On Error Resume Next

Range(Cells(1, 1), Cells(1, 2)) = Array("Исходный", "Сортирован")

Range(Cells(2, 1), Cells(UBound(Array1) + 1, 1)) = Array1

Range(Cells(2, 2), Cells(UBound(Array2) + 1, 2)) = Application.Transpose(Array2)

'If Err.Value <> 0 Then Cells(2, 1) = "Слишком много данных"

lblCurrentSort = "Завершено."

End Sub

Private Sub CancelButton_Click()

Unload Me

End Sub

Код подпрограммы, реализующей метод:

Option Explicit

'Этот алгоритм обрабатывает только значения типа Integer или Long.

Public Sub MetodSort (list() As Long, ByVal min As Long, ByVal max As Long)

Dim med_value As Long

Dim hi As Long

Dim lo As Long

Dim i As Long

' Если min >= max, список содержит 0 или 1 элемент,

' поэтому он уже отсортирован.

If min >= max Then Exit Sub

' Укажите разделяющее значение.

i = Int((max - min + 1) * Rnd + min)

med_value = list(i)

' Перемещение элемента вперед.

list(i) = list(min)

lo = min

hi = max

Do

' Look down from hi for a value < med_value.

Do While list(hi) >= med_value

hi = hi - 1

If hi <= lo Then Exit Do

Loop

If hi <= lo Then

list(lo) = med_value

Exit Do

End If

' Swap the lo and hi values.

list(lo) = list(hi)

' Поиск значения >= med_value.

lo = lo + 1

Do While list(lo) < med_value

lo = lo + 1

If lo >= hi Then Exit Do

Loop

If lo >= hi Then

lo = hi

list(hi) = med_value

Exit Do

End If

' Обмен значениями lo и hi.

list(hi) = list(lo)

Loop

' Сортировка двух подсписков.

MetodSort list(), min, lo - 1

MetodSort list(), lo + 1, max

End Sub

Метод пересчета

Код программы:

Option Explicit

Private Sub lblTime1_Click()

End Sub

Private Sub lblTime2_Click()

End Sub

Private Sub OKButton_Click()

Dim Array1() As Long, Array2() As Long

Dim i As Long

Dim Elements As Long, RElement As Long, Temp As Long

Dim Time1 As Date, Time2 As Date

Dim Msg As String

Dim r As Long

lblTime1.Caption = ""

' Проверка вводиых в форму данных

If Not IsNumeric(tbElements.Value) Then

MsgBox "Некорректные данные (нет элементов)", vbInformation

tbElements.SetFocus

Exit Sub

End If

Elements = Val(tbElements.Value)

If Elements < 1 Then

MsgBox "Некорректные данные (Нет элементов)", vbInformation

tbElements.SetFocus

Exit Sub

End If

' Формирование четырех идентичных массивов

lblCurrentSort = "Создание массива..."

Me.Repaint

Randomize

ReDim Array1(1 To Elements, 0)

ReDim Array2(1 To Elements)

For i = 1 To Elements

Array1(i, 0) = CLng(Rnd * 100000)

Array2(i) = Array1(i, 0)

Next i

' Сортировка методом пересчета

If CheckBox1 Then

lblCurrentSort = " Сортировка методом пересчета..."

Me.Repaint

Time1 = Timer

Call MetodSort (Array2)

Time2 = Timer

lblTime1.Caption = Format(Time2 - Time1, "00.00") & " сек."

Me.Repaint

End If

' Сохранение отсортированных данных

Worksheets("Данные").Activate

Cells.Clear

On Error Resume Next

Range(Cells(1, 1), Cells(1, 2)) = Array("Исходный", "Сортирован")

Range(Cells(2, 1), Cells(UBound(Array1) + 1, 1)) = Array1

Range(Cells(2, 2), Cells(UBound(Array2) + 1, 2)) = Application.Transpose(Array2)

'If Err.Value <> 0 Then Cells(2, 1) = "Слишком много данных"

lblCurrentSort = "Завершено."

End Sub

Private Sub CancelButton_Click()

Unload Me

End Sub

Код подпрограммы, реализующей метод:

Option Explicit

Sub MetodSort (list)

Dim counts()

Dim i As Long

Dim j As Long

Dim next_index As Long

Dim min, max

Dim min_value As Variant, max_value As Variant

' Создание массива счетчиков. VBA автоматически инициализирует все записи 0.

min_value = Minimum(list)

max_value = Maximum(list)

min = LBound(list)

max = UBound(list)

ReDim counts(min_value To max_value)

' Подсчет значений.

For i = min To max

counts(list(i)) = counts(list(i)) + 1

Next i

' Запись значений обратно в массив списка.

next_index = min

For i = min_value To max_value

For j = 1 To counts(i)

list(next_index) = i

next_index = next_index + 1

Next j

Next i

End Sub

Function Minimum(list)

Dim i As Long

Minimum = list(LBound(list))

For i = LBound(list) To UBound(list)

If list(i) < Minimum Then Minimum = list(i)

Next i

End Function

Function Maximum(list)

Dim i As Long

Maximum = list(LBound(list))

For i = LBound(list) To UBound(list)

If list(i) > Maximum Then Maximum = list(i)

Next i

End Function