Модернизация сорт-ки Шелла: некорректное смещение при сортировке куска массива. , Visual Basic v.6.0.

[Сергей85]

Данная функция была доработана так, что реализует:
- быструю сортировку по Шеллу;
- возможность ускоряться или работать без зависания ПО и возвращая время сортировки;
- сортировать любую часть массива, а не только массив целиком.

При вызове функции сортировки с 0 по любой больший индекс элемента - работает корректно и с дробными числами, вплоть до конца массива:
Call lSort_Array(dFormula_Array, 0, 9, True, "Тест: ", True)

Однако при смене 0 на не_начало_массива - сортируется неверно. Что подправить нужно в коде?

Private Function lSort_Array(ByRef dArray() As Double, lBegin_Element As Long, lEnd_Element As Double, bDirection As Boolean, sMessage As String, bReturn_Time As Boolean) As Long
'Сортировка методом Шелла - самая быстрая из сортировок рэндома. Возвращает затраченное время сортировки массива в секундах. Неточно.
 
1 On Error GoTo ErrorHandler
 
2 Dim dStep As Double 'Текущий шаг для сортировки вставкой.
3 Dim dTemp As Double 'Временная переменная для хранения значения вставки.
4 Dim i As Double, j As Double, k As Double 'Переменные для циклов сортировки методом Шелла.
5 Dim dateBegin_Time As Date 'Для вычисления времени работы в секундах.
 
6 If bReturn_Time Then dateBegin_Time = Time 'Если важна скорость - не тратить ресурсы на вычисление времени и индикацию выполнения.
 
7 dStep = Int((lEnd_Element - lBegin_Element) / 2) 'Работает и в случае нечетной размерности массива.
    
8 While dStep >= 1
9     If g_bCancel Then Exit Function 'Прерывание сортировки.
      
10    If bReturn_Time Then
11        DoEvents
12        Label_Process.Caption = sMessage & UBound(dArray) - dStep & " / " & UBound(dArray)
13    End If
        
14    For i = lBegin_Element To dStep
15        For j = i + dStep To lEnd_Element Step dStep
16            dTemp = dArray(j)
                
17            For k = j - dStep To lBegin_Element Step -dStep
18                If bDirection Xor (dTemp < dArray(k)) Then Exit For
19                dArray(k + dStep) = dArray(k)
20            Next k
 
21            dArray(k + dStep) = dTemp
22        Next j
23    Next i
      
24    dStep = Int(dStep / 2)
25 Wend
 
26 If bReturn_Time Then lSort_Array = DateDiff("s", dateBegin_Time, Time)
    
1000000 Exit Function
ErrorHandler:
1000001 If Err.Number <> 364 And Err.Number <> 0 Then MsgBox ("Ошибка функции lSort_Array №" & Err.Number & ", '" & Err.Description & "', строка " & Erl())
End Function

[Сергей85]

Сам допилил.

Стандартная сортировка Шелла была доработана так, что реализует:
- быструю сортировку по Шеллу;
- возможность ускоряться или работать без зависания ПО и возвращая время сортировки;
- сортировать любую часть массива, а не только массив целиком;
- сортировать синхронно два массива сразу.

Private Function lSort_Array(ByRef dArray() As Double, bDirection As Boolean, ByRef dWith_Array() As Double, Optional sMessage As String, Optional bReturn_Time As Boolean, Optional bWith_Array As Boolean, Optional lBegin_Element As Long, Optional lEnd_Element As Double) As Long
'Сортировка методом Шелла - самая быстрая из сортировок рэндома. Возвращает затраченное время сортировки массива в секундах.
'dArray() - Основной массив (указатель), bDirection - направление соритровки (True - по возрастанию), dWith_Array() - дополнительный массив (указатель, сортируется вместе с основным),
'sMessage - сообщение пользователю (индикатор независания ПО), bReturn_Time - ускорение сортировки или вывод sMessage и возврат времени выполнения в секундах,
'bWith_Array - так как массив нельзя указать Optional, флаг используется как наличие dWith_Array() (заглушка - dArray, False),
'lBegin_Element - начальный элемент для сортировки части массива (с нуля), lEnd_Element - конечный элемент для сортировки части массива (с нуля).
1 On Error GoTo ErrorHandler
 
2 Dim dStep As Double 'Текущий шаг для сортировки вставкой.
3 Dim dTemp As Double, dTemp2 As Double 'Временные переменные для хранения значения вставки.
4 Dim i As Double, j As Double, k As Double 'Переменные для циклов сортировки методом Шелла.
5 Dim dateBegin_Time As Date 'Для вычисления времени работы в секундах.
 
6 If bReturn_Time Then dateBegin_Time = Time 'Если важна скорость - не тратить ресурсы на вычисление времени и индикацию выполнения.
7 If lEnd_Element = 0 And lBegin_Element >= 0 Then lEnd_Element = UBound(dArray) 'Коррекция входных параметров Optional.
 
8 dStep = Int((lEnd_Element - lBegin_Element) / 2) 'Работает и в случае нечетной размерности массива.
 
9  If bWith_Array Then 'Задвоение кода из-за нескольких строк приводит к увеличению скорости на 30%.
10     While dStep >= 1
11         If g_bCancel Then Exit Function 'Прерывание сортировки.
      
12         If bReturn_Time Then
13             DoEvents
14             If sMessage <> "" Then Label_Process.Caption = sMessage & UBound(dArray) - dStep & " / " & UBound(dArray) + 1
15         End If
        
16         For i = lBegin_Element To dStep + lBegin_Element
17             For j = i + dStep To lEnd_Element Step dStep
18                 dTemp = dArray(j)
19                 dTemp2 = dWith_Array(j)
                
20                 For k = j - dStep To lBegin_Element Step -dStep
21                     If bDirection Xor (dTemp < dArray(k)) Then Exit For
22                     dArray(k + dStep) = dArray(k)
23                     dWith_Array(k + dStep) = dWith_Array(k)
24                 Next k
 
25                 dArray(k + dStep) = dTemp
26                 dWith_Array(k + dStep) = dTemp2
27             Next j
28         Next i
      
29         dStep = Int(dStep / 2)
30     Wend
31 Else
32     While dStep >= 1
33         If g_bCancel Then Exit Function 'Прерывание сортировки.
      
34         If bReturn_Time Then
35             DoEvents
36             If sMessage <> "" Then Label_Process.Caption = sMessage & UBound(dArray) - dStep & " / " & UBound(dArray) + 1
37         End If
        
38         For i = lBegin_Element To dStep + lBegin_Element
39            For j = i + dStep To lEnd_Element Step dStep
40                dTemp = dArray(j)
                
41                For k = j - dStep To lBegin_Element Step -dStep
42                    If bDirection Xor (dTemp < dArray(k)) Then Exit For
43                    dArray(k + dStep) = dArray(k)
44                Next k
 
45                dArray(k + dStep) = dTemp
46            Next j
47        Next i
      
48        dStep = Int(dStep / 2)
49    Wend
50 End If
 
51 If bReturn_Time Then lSort_Array = DateDiff("s", dateBegin_Time, Time)
    
1000000 Exit Function
ErrorHandler:
1000001 If Err.Number <> 364 And Err.Number <> 0 Then MsgBox ("Ошибка функции lSort_Array №" & Err.Number & ", '" & Err.Description & "', строка " & Erl())
End Function