ShellSortAlmost3.VBA

Sub SortingMain()
    Dim area As Range, nrOfValues As Long
    
    Set area = Range("A1").CurrentRegion
    nrOfValues = area.Cells.Count
    
    Call ShellSort(area, nrOfValues)

End Sub

Sub ShellSort(V As Range, nrOfValues&)
    Dim gap&, i&, k&, tmp&
    Dim noexchange As Boolean
    Dim comparisons As Long ' How many comparisons did every selection sentence do?
    Dim exchanged As Long ' How many times items were exchanged?
    Dim loop1 As Long, loop2 As Long, loop3 As Long ' How many iterations did every loop sentence do?
    comparisons = 0: exchanged = 0: loop1 = 0: loop2 = 0: loop3 = 0 ' Counters
    gap = nrOfValues
    Do While gap > 1
        loop1 = loop1 + 1
        gap = gap \ 2 'denominator = 2
        Do
            loop2 = loop2 + 1
            noexchange = True
            For i = 1 To nrOfValues - gap
                loop3 = loop3 + 1
                k = i + gap
                If V(k) > V(i) Then tmp = V(k): V(k) = V(i): V(i) = tmp: noexchange = False: exchanged = exchanged + 1
                comparisons = comparisons + 1
            Next i
        Loop Until noexchange = True
    Loop
    ' Show statistics
    Range("comparisons").Value = comparisons
    Range("exchanged").Value = exchanged
    Range("loop1").Value = loop1
    Range("loop2").Value = loop2
    Range("loop3").Value = loop3
    ' Almost (decreasingly) sorted – first and last items are exchanged: 1, 4, 3, 2, 5
    tmp = V(1): V(1) = V(nrOfValues): V(nrOfValues) = tmp
End Sub

Sub GenerateNumbersMain()
    Dim nrOfValues As Long, first As Long, last As Long
    Dim xy As Range, max As Long, pos As Long
    
    Set xy = Range("A1")
    first = Range("first").Value
    last = Range("last").Value
    nrOfValues = Range("nr_of_values").Value
    
    Call DeleteValues(xy)
    Call GenerateNumbers(xy, first, last, nrOfValues)

End Sub

Sub GenerateNumbers(xy As Range, first As Long, last As Long, howMany As Long)
    Dim i
    For i = 1 To howMany
        xy(i, 1) = Int(Rnd() * (last - first + 1) + first)
    Next i
End Sub

Sub DeleteValues(xy As Range)
    xy.CurrentRegion.ClearContents
End Sub