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

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

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