2. Метод пузырьковой сортировки Код программы:

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)

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() As Long)

' Сортировка массива с помощью алгоритма пузырьковой сортировки

' Работает с любым типом данных

Dim First As Integer, Last As Long

Dim i As Long, j As Long

Dim Temp

First = LBound(list)

Last = UBound(list)

For i = First To Last - 1

For j = i + 1 To Last

If list(i) > list(j) Then

Temp = list(j)

list(j) = list(i)

list(i) = Temp

End If

Next j

Next i

End Sub

3. Метод быстрой сортировки Код программы:

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