Метод сортировки на рабочем листе

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

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 (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

Sub MetodSort (list)

' Сортировка массива путем его перемещения на

' рабочий лист и применения команды сортировки Excel

Dim First As Integer, Last As Long

Dim i As Long

Dim FirstCell As Range, LastCell As Range

Dim CurrCell As Range, FillRange As Range

First = LBound(list, 1)

Last = UBound(list, 1)

Set FirstCell = Sheets("Лист1").Cells(1, 1)

Set LastCell = Sheets("Лист1").Cells(Last, 1)

Set FillRange = Range(FirstCell, LastCell)

Application.ScreenUpdating = False

' Перемещение массива на рабочий лист

FillRange.Value = list

' Сортировка диапазона на рабочем листе

FirstCell.CurrentRegion.Sort Key1:=FirstCell, Order1:=xlAscending, Orientation:=xlTopToBottom

' Перемещение диапазона обратно в массив и очистка диапазона

For i = First To Last

list(i, 0) = FirstCell.Offset(i - 1, 0)

Next i

FillRange.Clear

Application.ScreenUpdating = True

End Sub