Option Explicit

Const n As Long = 50

Dim Chrt As ChartObject

'**************************************************************

' Sub : Init

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Инициализация

'**************************************************************

Sub Init()

Set Chrt = ActiveSheet.ChartObjects(1)

End Sub

'**************************************************************

' Sub : RandomArray

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Перемешивание массива

'**************************************************************

Sub RandomArray()

Dim coll As New Collection

Dim rndVal As Long

Randomize

Do While coll.count < n

rndVal = CLng((n - 1) * Rnd) + 1

On Error Resume Next

coll.Add rndVal, CStr(rndVal)

If Err.Number = 0 Then Cells(1, coll.count) = rndVal

Err.Clear

Loop

End Sub

'**************************************************************

' Sub : StopSorting

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Остановка всех макросов

'**************************************************************

Sub StopSorting()

End

End Sub

'**************************************************************

' Sub : BubbleSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Сортировка простыми обменами, сортировка пузырьком

'**************************************************************

Sub BubbleSort()

Dim i As Long

Dim j As Long

Dim Flag As Boolean

Init

For i = 1 To n - 1

Flag = False

For j = 1 To n - i

If Cells(1, j) > Cells(1, j + 1) Then Swap Cells(1, j), Cells(1, j + 1): Flag = True

Next

If Not Flag Then Exit For

Next

End Sub

'**************************************************************

' Sub : ShakerSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Сортировка перемешиванием или Шейкерная сортировка

' или двунаправленная (англ. Cocktail sort) — разновидность пузырьковой сортировки

'**************************************************************

Sub ShakerSort()

Dim left As Long

Dim right As Long

Dim count As Long

Dim i As Long

Init

left = 1

right = n

count = 0

Do While left < right

For i = left To right - 1

count = count + 1

If Cells(1, i) > Cells(1, i + 1) Then Swap Cells(1, i), Cells(1, i + 1)

Next

right = right - 1

For i = right To left + 1 Step -1

count = count + 1

If Cells(1, i - 1) > Cells(1, i) Then Swap Cells(1, i - 1), Cells(1, i)

Next

left = left + 1

Loop

End Sub

'**************************************************************

' Sub : InsertionSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Сортировка вставками

'**************************************************************

Sub InsertionSort()

Dim i As Long

Dim j As Long

Init

For i = 2 To n

j = i

Do While j > 1

If Cells(1, j) > Cells(1, j - 1) Then Exit Do

Swap Cells(1, j), Cells(1, j - 1)

j = j - 1

Loop

Next

End Sub

'**************************************************************

' Sub : GnomeSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Гномья сортировка

'**************************************************************

Sub GnomeSort()

Dim i As Long

Dim j As Long

Init

i = 2

j = 2

Do While i < n + 1

If Cells(1, i - 1) < Cells(1, i) Then

i = j

j = j + 1

Else

Swap Cells(1, i - 1), Cells(1, i)

i = i - 1

If i = 1 Then

i = j

j = j + 1

End If

End If

Loop

End Sub

'**************************************************************

' Sub : BubbleSortWhithInsertion

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Объединение сортировки пузырьком и сортировки выбором

'**************************************************************

Sub BubbleSortWhithSelection()

Dim i As Long

Dim j As Long

Dim iMin As Long

Init

For i = 1 To n - 1

iMin = i

For j = i To n - i

If Cells(1, j) > Cells(1, j + 1) Then Swap Cells(1, j), Cells(1, j + 1)

If Cells(1, j) < Cells(1, iMin) Then iMin = j

Next

If iMin <> i Then Swap Cells(1, i), Cells(1, iMin)

Next

End Sub

'**************************************************************

' Sub : StartMergeSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Запуск сортировки слиянием

'**************************************************************

Sub StartMergeSort()

Init

MergeSort Range(Cells(1, 1), Cells(1, n))

End Sub

'**************************************************************

' Function : MergeSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Рекурсивная функция сортировки слиянием

'**************************************************************

Function MergeSort(rng As Range)

Dim left As Range

Dim right As Range

Dim result As Range

Dim i As Long

Dim middle As Long

If rng.Cells.count = 1 Then

Set MergeSort = rng

Exit Function

Else

middle = CLng(rng.Cells.count / 2)

' Разделяем диапазон на 2 части

Set left = Range(rng.Columns(1), rng.Columns(middle))

Set right = Range(rng.Columns(middle + 1), rng.Columns(rng.Columns.count))

' Рекурсивно проходим этой же функцией по каждой части

left = MergeSort(left)

right = MergeSort(right)

' Объединяем части обратно в единое целое

MergeSort = Merge(left, right)

End If

End Function

'**************************************************************

' Function : Merge

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Функция сортирует и объединяет диапазон

'**************************************************************

Function Merge(left As Range, right As Range) As Range

Dim i As Long

Dim count As Long

Dim result

Dim sizeLeft As Long

Dim sizeRight As Long

Dim FirstRng As Range

Set FirstRng = left.Cells(1, 1)

sizeLeft = left.count

sizeRight = right.count

ReDim result(1 To sizeLeft + sizeRight)

i = 1

Do While sizeLeft > 0 And sizeRight > 0

If left.Columns(1) <= right.Columns(1) Then

result(i) = left.Columns(1)

If sizeLeft > 1 Then Set left = left.Offset(, 1).Resize(, left.Columns.count - 1)

sizeLeft = sizeLeft - 1

Else

result(i) = right.Columns(1)

If sizeRight > 1 Then Set right = right.Offset(, 1).Resize(, right.Columns.count - 1)

sizeRight = sizeRight - 1

End If

i = i + 1

Loop

Do While sizeLeft > 0

result(i) = left.Columns(1)

If sizeLeft > 1 Then Set left = left.Offset(, 1).Resize(, left.Columns.count - 1)

sizeLeft = sizeLeft - 1

i = i + 1

Loop

Do While sizeRight > 0

result(i) = right.Columns(1)

If sizeRight > 1 Then Set right = right.Offset(, 1).Resize(, right.Columns.count - 1)

sizeRight = sizeRight - 1

i = i + 1

Loop

For i = 1 To UBound(result)

FirstRng.Offset(, i - 1) = result(i)

ChartRefresh

Next

Set Merge = FirstRng.Resize(, UBound(result))

End Function

'**************************************************************

' Sub : StartQuickSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Запуск быстрой сортировки

'**************************************************************

Sub StartQuickSort()

Init

QuickSort Range(Cells(1, 1), Cells(1, n)), 1, n

End Sub

'**************************************************************

' Sub : QuickSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Рекурсивная функция для быстрой сортировки

'**************************************************************

Sub QuickSort(rng As Range, lo, hi)

Dim p As Long

If lo < hi Then

p = Partition(rng, lo, hi)

Call QuickSort(rng, lo, p)

Call QuickSort(rng, p + 1, hi)

End If

End Sub

'**************************************************************

' Function : Partition

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Выбор опорного элемента для быстрой сортировки

'**************************************************************

Function Partition(rng As Range, lo, hi)

Dim i As Long

Dim j As Long

Dim pivot

i = lo

j = hi

pivot = (rng.Cells(1, lo) + rng.Cells(1, hi)) / 2

Do

Do While rng.Cells(1, i) < pivot

i = i + 1

Loop

Do While rng.Cells(1, j) > pivot

j = j - 1

Loop

If i >= j Then

Partition = j

Exit Function

End If

Swap rng.Cells(1, i), rng.Cells(1, j)

Loop

End Function

'**************************************************************

' Sub : SelectionSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Сортировка выбором

'**************************************************************

Sub SelectionSort()

Dim i As Long

Dim j As Long

Dim iMin As Long

Init

For i = 1 To n

iMin = i

For j = i To n

If Cells(1, j) < Cells(1, iMin) Then iMin = j

Next

If iMin <> i Then Swap Cells(1, i), Cells(1, iMin)

Next

End Sub

'**************************************************************

' Sub : HeapSort

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Пирамидальная сортировка

'**************************************************************

Sub HeapSort()

Dim i As Long

Dim j As Long

Init

For i = 1 To n

For j = CInt((n + 1) / 2) - CInt(i / 2) To 1 Step -1

If 2 * j + 1 <= n - i + 1 Then

If Cells(1, 2 * j) > Cells(1, 2 * j + 1) Then

If Cells(1, j) < Cells(1, 2 * j) Then

Swap Cells(1, j), Cells(1, 2 * j)

End If

Else

If Cells(1, j) < Cells(1, 2 * j + 1) Then

Swap Cells(1, j), Cells(1, 2 * j + 1)

End If

End If

Else

If 2 * j <= n - i + 1 Then

If Cells(1, j) < Cells(1, 2 * j) Then

Swap Cells(1, j), Cells(1, 2 * j)

End If

End If

End If

Next

Swap Cells(1, 1), Cells(1, n - i + 1)

Next

End Sub

'**************************************************************

' Sub : Swap

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Перестановка ячеек

'**************************************************************

Sub Swap(A As Range, B As Range)

Dim C As String

C = A

A = B

B = C

ChartRefresh

End Sub

'**************************************************************

' Sub : ChartRefresh

' Author : Zheltov Alexey

' Date : 24.12.2020

' Purpose : Обновление диаграммы

'**************************************************************

Sub ChartRefresh()

Chrt.Activate

Application.Calculate

DoEvents

End Sub