Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
14.01.2018 12:13:42
В текущем варианте - это надстройка-симбионт ускоряющая работу основного сортера на средних и больших массивах. Степень ускорения зависит от входных данных. При равномерном распределении, и диапазоне значений (числа) равными/кратными количеству элементов в сортируемом столбце массива, досортировка почти не требуется. Например "голые" (без временных нашлёпок) даты не нуждаются в досортировке - отсюда и высокая скорость обработки. Можно ли считать это РЕШЕНИЕМ? Отчасти, и в основном из уважения к труду AAF, т.к. именно его сортировщик делает основную работу. --------------------------------- Изменения: - исправил пару косяков - добавлен Excel sort на стенд - сам сортировщик от AAF перенесён в модуль к "клеверу", поэтому если кому нужно, то можно экспортировать модуль и вставить в свой проект. - выгрузка итогов сортировки идет во входной массив.
Пример использования есть в коде тестового стенда. Более подробно в комментариях к самому сортеру-сателлиту.
П.С.: Изобретение "велосипеда" продолжается --------------------------- Тест на 5КК*1 (картинка):
Скрытый текст
Как выяснилось на системах с разными процессорами со всеми чипсетами скорость отличается, причем прилично. Хотя возможно дело в версии Excel. Первый скрин на 2007, второй на 2013. AMD Phenom ™ II X4 965 3.4 GHz: Intel i5 .... 3.2 GHz: Метод Resize не захотел работать с таким массивом, поэтому без сортера Excel.
Есть еще вариант разбивки распределителя на модули (числа, даты, текст). Сократится кол-во переменных в каждом отдельно взятом модуле, уменьшится время индексации (не будет проверки на тип входных данных), на деиндексации тоже. Но это когда известно заранее, что за данные в массиве.
Можно. Но для того, чтобы перенести какую-то тему в Копилку, ее нужно сначала создать, изложить в сообщении функционал и описание, приложить файл.
Пользователь
Сообщений: Регистрация: 18.12.2016
14.01.2018 12:30:42
oldy7, может еще прокатать пару раз, ибо мне кажется можно переписать код с оптимизацией с точки зрения интеграции в Ваше решение, а уже потом сделать описание и примеры... Но времени мало и недельку надо еще... Да, и еще compare text прикрутить надо.
Изменено: - 14.01.2018 12:33:12
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
14.01.2018 12:44:49
AAF, я его вчера гонял в течении дня в перерывах между домашними делами и просмотрами серила) Для Compare Text нужно переделывать текстовый распределитель. Я этим занимаюсь, но с целью оптимизации оного и вывода этого распределителя в самостоятельный алгоритм с минимальной досортировкой.
Sub SortGen(a() As Variant, c As Long, a0() As Long, o As Integer)
Dim s As Long, f As Long, x As Long, i As Long, j As Long, n As Long
Dim begin As Long, endin As Long
Dim v As Byte: v = 1
Dim a1() As Long: a1 = a0
Dim aF() As Long: ReDim aF(1 To Fix((UBound(a0) - LBound(a0)) / 2 + 1)): n = 1
If o > 0 Then
begin = LBound(a0): endin = UBound(a0)
Else
begin = UBound(a0): endin = LBound(a0)
End If
j = begin: aF(1) = begin
For i = begin + o To endin Step o
If a(a0(i), c) < a(a0(i - o), c) Then
Select Case v
Case 110: v = 1
If s = j Then
f = f + o
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): j = j + o: f = f + o
For s = j - o To f - 2 * o Step o
For f = f To i - o Step o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
Else
f = s + o
For s = s To j Step -o
For f = f To i - o Step o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
End If
j = i
n = n + 1: aF(n) = i
Case 111: v = 0: f = i - o
Case 1: v = 101: f = i - o
Case 0: v = 100
End Select
Else
Select Case v
Case 100: v = 1
If s = j Then
f = i - o
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): s = j: j = j + o: f = f - o
For j = j To i - o Step o
If a(a0(f), c) < a(a0(s), c) Then
a1(j) = a0(f): f = f - o
Else
a1(j) = a0(s): s = s + o
End If
Next
Else
f = i - o: x = s + o
For s = s To j Step -o
For f = f To x Step -o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
For j = j To i - o Step o
a1(j) = a0(f): f = f - o
Next
End If
n = n + 1: aF(n) = i
Case 101: v = 0: s = i - o
Case 0: v = 110
Case 1: v = 111: s = i - o
End Select
End If
Next
Select Case v
Case 0
If s = j Then
n = n + 1: aF(n) = f + o
Else
For s = s To f Step -o
If a(a0(endin), c) < a(a0(s), c) Then Exit For
a1(j) = a0(s): j = j + o
Next
a1(j) = a0(endin): j = j + o
For s = s To f Step -o
a1(j) = a0(s): j = j + o
Next
End If
Case 1
If a(a1(endin), c) > a(a1(endin - o), c) Then n = n - 1
Case 101
s = endin
For j = j To endin Step o
a1(j) = a0(s): s = s - o
Next
Case 110: v = 1
If s = j Then
n = n + 1: aF(n) = f + o
Else
f = s + o
For s = s To j Step -o
For f = f To endin Step o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
End If
Case 100
If s = j Then
f = endin
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): s = j: j = j + o: f = f - o
For j = j To endin Step o
If a(a0(f), c) < a(a0(s), c) Then
a1(j) = a0(f): f = f - o
Else
a1(j) = a0(s): s = s + o
End If
Next
Else
f = endin: x = s + o
For s = s To j Step -o
For f = f To x Step -o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
For j = j To endin Step o
a1(j) = a0(f): f = f - o
Next
End If
End Select
n = n + 1: aF(n) = endin + o: ReDim Preserve aF(1 To n)
Do
a0 = a1: j = begin: n = 1
For i = 2 To UBound(aF) - 1 Step 2
f = aF(i): x = aF(i + 1) - o
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): j = j + o: f = f + o
For s = j - o To f - 2 * o Step o
For f = f To x Step o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
j = x + o: n = n + 1: aF(n) = j
Next
If i - UBound(aF) = 0 Then
n = n + 1: aF(n) = endin + o
End If
ReDim Preserve aF(1 To n)
Loop Until n = 2
a0 = a1: Erase a1: Erase aF:
End Sub
Sub SortStr(a() As Variant, c As Long, a0() As Long, Optional o As Integer, Optional cM As Byte)
Dim s As Long, f As Long, x As Long, i As Long, j As Long, n As Long
Dim v As Byte: v = 1
Dim a1() As Long: a1 = a0
Dim aF() As Long: ReDim aF(1 To Fix((UBound(a0) - LBound(a0)) / 2 + 1)): n = 1
j = LBound(a0): aF(1) = j
For i = LBound(a0) + 1 To UBound(a0)
If StrComp(a(a0(i - 1), c), a(a0(i), c), cM) = o Then
Select Case v
Case 110: v = 1
If s = j Then
f = f + 1
Do Until StrComp(a(a0(j), c), a(a0(f), c), cM) = o: j = j + 1: Loop
a1(j) = a0(f): j = j + 1: f = f + 1
For s = j - 1 To f - 2
For f = f To i - 1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
Else
f = s + 1
For s = s To j Step -1
For f = f To i - 1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
End If
j = i
n = n + 1: aF(n) = i
Case 111: v = 0: f = i - 1
Case 1: v = 101: f = i - 1
Case 0: v = 100
End Select
Else
Select Case v
Case 100: v = 1
If s = j Then
f = i - 1
Do Until StrComp(a(a0(j), c), a(a0(f), c), cM) = o: j = j + 1: Loop
a1(j) = a0(f): s = j: j = j + 1: f = f - 1
For j = j To i - 1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then
a1(j) = a0(f): f = f - 1
Else
a1(j) = a0(s): s = s + 1
End If
Next
Else
f = i - 1: x = s + 1
For s = s To j Step -1
For f = f To x Step -1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
For j = j To i - 1
a1(j) = a0(f): f = f - 1
Next
End If
n = n + 1: aF(n) = i
Case 101: v = 0: s = i - 1
Case 0: v = 110
Case 1: v = 111: s = i - 1
End Select
End If
Next
Select Case v
Case 0
If s = j Then
n = n + 1: aF(n) = f + 1
Else
For s = s To f Step -1
If StrComp(a(a0(s), c), a(a0(UBound(a0)), c), cM) = o Then Exit For
a1(j) = a0(s): j = j + 1
Next
a1(j) = a0(UBound(a0)): j = j + 1
For s = s To f Step -1
a1(j) = a0(s): j = j + 1
Next
End If
Case 1
If StrComp(a(a0(UBound(a0)), c), a(a0(UBound(a0) - 1), c), cM) = o Then n = n - 1
Case 101
s = UBound(a0)
For j = j To UBound(a0)
a1(j) = a0(s): s = s - 1
Next
Case 110: v = 1
If s = j Then
n = n + 1: aF(n) = f + 1
Else
f = s + 1
For s = s To j Step -1
For f = f To UBound(a0) Step o
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + 1
Next
End If
Case 100
If s = j Then
f = UBound(a0)
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): s = j: j = j + o: f = f - o
For j = j To UBound(a0)
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then
a1(j) = a0(f): f = f - 1
Else
a1(j) = a0(s): s = s + 1
End If
Next
Else
f = UBound(a0): x = s + 1
For s = s To j Step -1
For f = f To x Step -1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
For j = j To UBound(a0)
a1(j) = a0(f): f = f - 1
Next
End If
End Select
n = n + 1: aF(n) = UBound(a0) + 1: ReDim Preserve aF(1 To n)
Do
a0 = a1: j = LBound(a0): n = 1
For i = 2 To UBound(aF) - 1 Step 2
f = aF(i): x = aF(i + 1) - 1
Do Until StrComp(a(a0(j), c), a(a0(f), c), cM) = o: j = j + 1: Loop
a1(j) = a0(f): j = j + 1: f = f + 1
For s = j - 1 To f - 2
For f = f To x
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
j = x + 1: n = n + 1: aF(n) = j
Next
If i - UBound(aF) = 0 Then
n = n + 1: aF(n) = UBound(a0) + 1
End If
ReDim Preserve aF(1 To n)
Loop Until n = 2
a0 = a1: Erase a1: Erase aF:
End Sub
Function DBound(a) As Integer
Dim u As Long, d As Integer
On Error Resume Next
Do: d = d + 1: u = UBound(a, d): Loop Until Err.Number
DBound = d - 1
End Function
Function SortFull(a(), col, Optional aIdx, Optional orderSort, Optional compareMode)
Dim aC() As Long, a0() As Long, cM As Byte, o As Integer, aResult()
Dim aSt0() As Long, aStr() As Long, aEmp() As Long, aNum() As Long
Dim iSt0 As Long, iStr As Long, iEmp As Long, iNum As Long
Dim i As Long, j As Long, x, c As Long, f As Boolean
If DBound(a) <> 2 Then Exit Function
If DBound(aIdx) = 1 Then
a0 = aIdx
Else
ReDim a0(LBound(a) To UBound(a))
For i = LBound(a) To UBound(a): a0(i) = i: Next
End If
If IsArray(col) Then
ReDim aC(LBound(col) To UBound(col))
i = UBound(col)
For Each x In col
aC(i) = x: i = i - 1
Next
Else
ReDim aC(1 To 1): aC(1) = col
End If
ReDim aO(LBound(aC) To UBound(aC))
ReDim aM(LBound(aC) To UBound(aC))
i = UBound(aC)
If IsArray(orderSort) Then
For Each x In orderSort
If i < LBound(aC) Then Exit For
If x = -1 Then aO(i) = -1 Else aO(i) = 1
i = i - 1
Next
x = aO(i + 1)
For i = i To LBound(aC) Step -1
aO(i) = x
Next
Else
If orderSort = -1 Then x = -1 Else x = 1
For i = i To LBound(aC) Step -1
aO(i) = x
Next
End If
i = UBound(aC)
If IsArray(compareMode) Then
For Each x In orderSort
If i < LBound(aC) Then Exit For
If x < 1 Or x > 2 Then aM(i) = 0 Else aM(i) = x
i = i - 1
Next
x = aM(i + 1)
For i = i To LBound(aC) Step -1
aM(i) = x
Next
Else
If compareMode < 1 Or compareMode > 2 Then x = 0 Else x = compareMode
For i = i To LBound(aC) Step -1
aM(i) = x
Next
End If
For j = LBound(aC) To UBound(aC)
c = aC(j): o = aO(j): cM = aM(j)
ReDim aSt0(LBound(a0) To UBound(a0)): iSt0 = LBound(a0)
aEmp = aSt0: iEmp = iSt0: aStr = aSt0: iStr = iSt0: aNum = aSt0: iNum = iSt0
For Each x In a0
If VarType(a(x, c)) = 8 Then
If a(x, c) = "" Then
aSt0(iSt0) = x: iSt0 = iSt0 + 1
Else
aStr(iStr) = x: iStr = iStr + 1
End If
Else
If IsEmpty(a(x, c)) Then
aEmp(iEmp) = x: iEmp = iEmp + 1
Else
aNum(iNum) = x: iNum = iNum + 1
End If
End If
Next
i = LBound(a0)
If iNum > LBound(a0) Then
If iNum <= UBound(a0) Then ReDim Preserve aNum(LBound(a0) To iNum - 1)
SortGen a, c, aNum, o
ReDim Preserve aNum(LBound(a0) To UBound(a0)): a0 = aNum: f = True: i = iNum
End If
Erase aNum
If iStr > LBound(a0) Then
If iStr <= UBound(a0) Then ReDim Preserve aStr(LBound(a0) To iStr - 1)
SortStr a, c, aStr, o, cM
If f Then
For Each x In aStr
a0(i) = x: i = i + 1
Next
Else
ReDim Preserve aStr(LBound(a0) To UBound(a0)): a0 = aStr: f = True: i = iStr
End If
End If
Erase aStr
If iSt0 > LBound(a0) Then
If f Then
If iSt0 <= UBound(a0) Then ReDim Preserve aSt0(LBound(a0) To iSt0 - 1)
For Each x In aSt0
a0(i) = x: i = i + 1
Next
Else
a0 = aSt0: f = True: i = iSt0
End If
End If
Erase aSt0
If iEmp > LBound(a0) Then
If f Then
If iEmp <= UBound(a0) Then ReDim Preserve aEmp(LBound(a0) To iEmp - 1)
For Each x In aEmp
a0(i) = x: i = i + 1
Next
Else
a0 = aEmp
End If
End If
Erase aEmp: f = False
Next
ReDim aResult(LBound(a0) To UBound(a0), LBound(a, 2) To UBound(a, 2))
For j = LBound(a, 2) To UBound(a, 2)
For i = LBound(a0) To UBound(a0)
aResult(i, j) = a(a0(i), j)
Next
Next
aIdx = a0: Erase a0
SortFull = aResult
End Function
Результат складывается в порядке: НЕ текст, текст, "", Empty
Код
'Сортировка по нескольким столбцам
aResult = SortFull(a, Array(2, 1), , Array(1, -1), Array(1, 0))
'Сортировка по одному столбцу
aResult = SortFull(a, 2, , -1, 0)
Изменено: - 15.01.2018 13:59:51
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
15.01.2018 18:48:56
AAF, серьёзную работу провели. Мультисортинг при сортировке по индексам так и напрашивался --------------- Исправил еще две ошибки в своем коде. Файлик в первом сообщении на этой странице обновил. Также провёл тест на компе на работе. Картинку тоже добавил.
Борюсь с текстовым распределителем. Вынес себе мозг многократно вложенными массивами:
Скрытый текст
Подобные конструкции вымораживают)
Код
tMatrix(c)(b)(ch1)(1) = tMatrix(c)(b)(ch1)(1) + 1
If UBound(tMatrix(c)(b)(ch1)) = tMatrix(c)(b)(ch1)(2) Then
arr = tMatrix(c)(b)(ch1): ReDim Preserve arr(tMatrix(c)(b)(ch1)(1) + 5)
End If
tMatrix(c)(b)(ch1)(tMatrix(c)(b)(ch1)(2)) = mtrx(x)
tMatrix(c)(b)(ch1)(2) = tMatrix(c)(b)(ch1)(2) + 1
Есть мысль перейти на UDT. Провел пару тестов - скорость записи/чтения высокая.
Есть такое, но хочется чего-то концептуального, что пройдет красной нитью через все решение, поэтому не делал лишних шагов, а остановился на достигнутом. (До UDT пока не дошел в данном применении ) А теперь робкое предложение (прошу не воспринимать как проявление безусловного эгоизма) Это переписанный код SortFull:
Код
Function SortClever(a(), col, Optional aIdx, Optional orderSort, Optional compareMode)
'Может необходимо добавить еще какие-то входящие переменные
Dim aC() As Long, a0() As Long, cM As Byte, o As Integer, aResult()
Dim aSt0() As Long, aStr() As Long, aEmp() As Long, aNum() As Long
Dim iSt0 As Long, iStr As Long, iEmp As Long, iNum As Long
Dim i As Long, j As Long, x, c As Long, f As Boolean
'Dim какие-то Ваши переменные
If DBound(a) <> 2 Then Exit Function
If DBound(aIdx) = 1 Then
a0 = aIdx
Else
ReDim a0(LBound(a) To UBound(a))
For i = LBound(a) To UBound(a): a0(i) = i: Next
End If
If IsArray(col) Then
ReDim aC(LBound(col) To UBound(col))
i = UBound(col)
For Each x In col
aC(i) = x: i = i - 1
Next
Else
ReDim aC(1 To 1): aC(1) = col
End If
ReDim aO(LBound(aC) To UBound(aC))
ReDim aM(LBound(aC) To UBound(aC))
i = UBound(aC)
If IsArray(orderSort) Then
For Each x In orderSort
If i < LBound(aC) Then Exit For
If x = -1 Then aO(i) = -1 Else aO(i) = 1
i = i - 1
Next
x = aO(i + 1)
For i = i To LBound(aC) Step -1
aO(i) = x
Next
Else
If orderSort = -1 Then x = -1 Else x = 1
For i = i To LBound(aC) Step -1
aO(i) = x
Next
End If
i = UBound(aC)
If IsArray(compareMode) Then
For Each x In orderSort
If i < LBound(aC) Then Exit For
If x < 1 Or x > 2 Then aM(i) = 0 Else aM(i) = x
i = i - 1
Next
x = aM(i + 1)
For i = i To LBound(aC) Step -1
aM(i) = x
Next
Else
If compareMode < 1 Or compareMode > 2 Then x = 0 Else x = compareMode
For i = i To LBound(aC) Step -1
aM(i) = x
Next
End If
For j = LBound(aC) To UBound(aC)
c = aC(j): o = aO(j): cM = aM(j)
' здесь мы имеем следующие данные:
' a0 - массив индексов подвергаемые сортировке
' a - сам собсно массив
' c - текущий столбец сортировки
' o - порядок сортировки
' cM - метод сравнения
' А теперь все что хочет Clever
' далее страдаем сепаратизмом согласно некоего алгоритма
' проводим сортировку внутри фрагментов сепаратора
' для сортировки используем любые необходимые процедуры/функции
' проводим сборку
' получаем в результате a0 (отсортированные индексы)
' a0 будет передано к следующей сортировке если она есть (столбец для сортировки не один)
Next
ReDim aResult(LBound(a0) To UBound(a0), LBound(a, 2) To UBound(a, 2))
For j = LBound(a, 2) To UBound(a, 2)
For i = LBound(a0) To UBound(a0)
aResult(i, j) = a(a0(i), j)
Next
Next
aIdx = a0: Erase a0
SortClever = aResult
End Function
Просто ради унификации, но если это алгоритмически возможно, естественно
Изменено: - 16.01.2018 12:53:26
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
16.01.2018 05:48:29
AAF, если это попытка скрестить распределение с сортировкой под одной крышей, то есть пару нюансов: - по результатам первичной сепарации данных вызов Вашего сортера идет для каждой ветви данных - только по числам есть два вызова процедуры досортировки, т.е. всего четыре раза - условия вызова в на каждой ветке немного отличаются (до определенного момента, а точнее до опред.кол-ва досортируемых элементов работает безсвопинговая "вставка" - она быстрее на мелких массивах). Плюс для чисел, дат и текста используются при сравнении разные переменные соотв.типа. - и если произвести четыре включения Вашего кода в мой, то это будет ядреный листинг на много страниц) Он и так не маленький.
Да нет, необязательно, я подразумевал только вызов оттуда одиночных сортировок, которые не переписывают входящий массив, а возвращают отсортированные индексы в виде массива и все.
Изменено: - 16.01.2018 12:46:54
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
16.01.2018 18:24:17
Цитата
AAF написал: я подразумевал только вызов оттуда одиночных сортировок, которые не переписывают входящий массив, а возвращают отсортированные индексы в виде массива
Так там (в "клевере") и так можно гонять внутренний сортировщик по столбцам, нужно лишь добавить внешний цикл и первичную индексацию по первому столбцу из тех, что будут сортироваться. Поэтому там перед окончательной выгрузкой идет сборка субиндексных массивов в один.
Кстати, попробую обойтись без этой сборки, а писать сразу в один общий раз ограничители этих массивов (по типам данных) вычисляются в самом начале. Все быстрее будет)
П.С.: По Вашему примеру убрал замену пустот на массив с индексами по пустотам. -------------------- Добавил мультисортинг, убрал фильтр (он не стыкуется с сортировкой по нескольким столбцам). Параметров процедуры осталось всего два: вариантный одномерный массив, в котором номера столбцов чередуются с флагами сортировки (False - по возрастанию, True - по убыванию), сортируемый массив. Проверки с автокоррекцией содержимого массива с номерами столбцов нет. Также добавлен распределитель для отрицательных чисел - не тестировался. --------upd------- Провёл небольшую оптимизацию по числовым сортировкам и промежуточной сшивке индексных массивов в один.
oldy7, добавил всего одно условие в обе процедуры для оптимизации скорости, после Вашего сепаратора, т.к. при среднестатичстическом распределении это не уменьшит время... Времени на тестирование к сожалению не было...
Скрытый текст
Код
Sub SortGen(a() As Variant, c As Long, a0() As Long, o As Integer)
Dim s As Long, f As Long, x As Long, i As Long, j As Long, n As Long
Dim begin As Long, endin As Long
Dim v As Byte: v = 1
If UBound(a0) - LBound(a0) = 0 Then Exit Sub
Dim a1() As Long: a1 = a0
Dim aF() As Long: ReDim aF(1 To Fix((UBound(a0) - LBound(a0)) / 2 + 1)): n = 1
If o > 0 Then
begin = LBound(a0): endin = UBound(a0)
Else
begin = UBound(a0): endin = LBound(a0)
End If
j = begin: aF(1) = begin
For i = begin + o To endin Step o
If a(a0(i), c) < a(a0(i - o), c) Then
Select Case v
Case 110: v = 1
If s = j Then
f = f + o
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): j = j + o: f = f + o
For s = j - o To f - 2 * o Step o
For f = f To i - o Step o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
Else
f = s + o
For s = s To j Step -o
For f = f To i - o Step o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
End If
j = i
n = n + 1: aF(n) = i
Case 111: v = 0: f = i - o
Case 1: v = 101: f = i - o
Case 0: v = 100
End Select
Else
Select Case v
Case 100: v = 1
If s = j Then
f = i - o
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): s = j: j = j + o: f = f - o
For j = j To i - o Step o
If a(a0(f), c) < a(a0(s), c) Then
a1(j) = a0(f): f = f - o
Else
a1(j) = a0(s): s = s + o
End If
Next
Else
f = i - o: x = s + o
For s = s To j Step -o
For f = f To x Step -o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
For j = j To i - o Step o
a1(j) = a0(f): f = f - o
Next
End If
n = n + 1: aF(n) = i
Case 101: v = 0: s = i - o
Case 0: v = 110
Case 1: v = 111: s = i - o
End Select
End If
Next
Select Case v
Case 0
If s = j Then
n = n + 1: aF(n) = f + o
Else
For s = s To f Step -o
If a(a0(endin), c) < a(a0(s), c) Then Exit For
a1(j) = a0(s): j = j + o
Next
a1(j) = a0(endin): j = j + o
For s = s To f Step -o
a1(j) = a0(s): j = j + o
Next
End If
Case 1
If a(a1(endin), c) > a(a1(endin - o), c) Then n = n - 1
Case 101
s = endin
For j = j To endin Step o
a1(j) = a0(s): s = s - o
Next
Case 110: v = 1
If s = j Then
n = n + 1: aF(n) = f + o
Else
f = s + o
For s = s To j Step -o
For f = f To endin Step o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
End If
Case 100
If s = j Then
f = endin
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): s = j: j = j + o: f = f - o
For j = j To endin Step o
If a(a0(f), c) < a(a0(s), c) Then
a1(j) = a0(f): f = f - o
Else
a1(j) = a0(s): s = s + o
End If
Next
Else
f = endin: x = s + o
For s = s To j Step -o
For f = f To x Step -o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
For j = j To endin Step o
a1(j) = a0(f): f = f - o
Next
End If
End Select
n = n + 1: aF(n) = endin + o: ReDim Preserve aF(1 To n)
Do
a0 = a1: j = begin: n = 1
For i = 2 To UBound(aF) - 1 Step 2
f = aF(i): x = aF(i + 1) - o: s = f - o
If a(a0(s), c) > a(a0(f), c) Then
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): j = j + o: f = f + o
For s = j - o To f - 2 * o Step o
For f = f To x Step o
If a(a0(f), c) < a(a0(s), c) Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + o
Next
End If
j = x + o: n = n + 1: aF(n) = j
Next
If i - UBound(aF) = 0 Then
n = n + 1: aF(n) = endin + o
End If
ReDim Preserve aF(1 To n)
Loop Until n = 2
a0 = a1: Erase a1: Erase aF:
End Sub
Скрытый текст
Код
Sub SortStr(a() As Variant, c As Long, a0() As Long, Optional o As Integer, Optional cM As Byte)
Dim s As Long, f As Long, x As Long, i As Long, j As Long, n As Long
Dim v As Byte: v = 1
Dim a1() As Long: a1 = a0
Dim aF() As Long: ReDim aF(1 To Fix((UBound(a0) - LBound(a0)) / 2 + 1)): n = 1
j = LBound(a0): aF(1) = j
For i = LBound(a0) + 1 To UBound(a0)
If StrComp(a(a0(i - 1), c), a(a0(i), c), cM) = o Then
Select Case v
Case 110: v = 1
If s = j Then
f = f + 1
Do Until StrComp(a(a0(j), c), a(a0(f), c), cM) = o: j = j + 1: Loop
a1(j) = a0(f): j = j + 1: f = f + 1
For s = j - 1 To f - 2
For f = f To i - 1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
Else
f = s + 1
For s = s To j Step -1
For f = f To i - 1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
End If
j = i
n = n + 1: aF(n) = i
Case 111: v = 0: f = i - 1
Case 1: v = 101: f = i - 1
Case 0: v = 100
End Select
Else
Select Case v
Case 100: v = 1
If s = j Then
f = i - 1
Do Until StrComp(a(a0(j), c), a(a0(f), c), cM) = o: j = j + 1: Loop
a1(j) = a0(f): s = j: j = j + 1: f = f - 1
For j = j To i - 1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then
a1(j) = a0(f): f = f - 1
Else
a1(j) = a0(s): s = s + 1
End If
Next
Else
f = i - 1: x = s + 1
For s = s To j Step -1
For f = f To x Step -1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
For j = j To i - 1
a1(j) = a0(f): f = f - 1
Next
End If
n = n + 1: aF(n) = i
Case 101: v = 0: s = i - 1
Case 0: v = 110
Case 1: v = 111: s = i - 1
End Select
End If
Next
Select Case v
Case 0
If s = j Then
n = n + 1: aF(n) = f + 1
Else
For s = s To f Step -1
If StrComp(a(a0(s), c), a(a0(UBound(a0)), c), cM) = o Then Exit For
a1(j) = a0(s): j = j + 1
Next
a1(j) = a0(UBound(a0)): j = j + 1
For s = s To f Step -1
a1(j) = a0(s): j = j + 1
Next
End If
Case 1
If StrComp(a(a0(UBound(a0)), c), a(a0(UBound(a0) - 1), c), cM) = o Then n = n - 1
Case 101
s = UBound(a0)
For j = j To UBound(a0)
a1(j) = a0(s): s = s - 1
Next
Case 110: v = 1
If s = j Then
n = n + 1: aF(n) = f + 1
Else
f = s + 1
For s = s To j Step -1
For f = f To UBound(a0) Step o
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + o
Next
a1(j) = a0(s): j = j + 1
Next
End If
Case 100
If s = j Then
f = UBound(a0)
Do Until a(a0(f), c) < a(a0(j), c): j = j + o: Loop
a1(j) = a0(f): s = j: j = j + o: f = f - o
For j = j To UBound(a0)
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then
a1(j) = a0(f): f = f - 1
Else
a1(j) = a0(s): s = s + 1
End If
Next
Else
f = UBound(a0): x = s + 1
For s = s To j Step -1
For f = f To x Step -1
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
For j = j To UBound(a0)
a1(j) = a0(f): f = f - 1
Next
End If
End Select
n = n + 1: aF(n) = UBound(a0) + 1: ReDim Preserve aF(1 To n)
Do
a0 = a1: j = LBound(a0): n = 1
For i = 2 To UBound(aF) - 1 Step 2
f = aF(i): x = aF(i + 1) - 1
If StrComp(a(a0(f - 1), c), a(a0(f), c), cM) = -o Then
Do Until StrComp(a(a0(j), c), a(a0(f), c), cM) = o: j = j + 1: Loop
a1(j) = a0(f): j = j + 1: f = f + 1
For s = j - 1 To f - 2
For f = f To x
If StrComp(a(a0(s), c), a(a0(f), c), cM) = o Then a1(j) = a0(f) Else Exit For
j = j + 1
Next
a1(j) = a0(s): j = j + 1
Next
End If
j = x + 1: n = n + 1: aF(n) = j
Next
If i - UBound(aF) = 0 Then
n = n + 1: aF(n) = UBound(a0) + 1
End If
ReDim Preserve aF(1 To n)
Loop Until n = 2
a0 = a1: Erase a1: Erase aF:
End Sub
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
20.01.2018 20:28:00
AAF, да, согласен. Гонял миллионы тестируя и оптимизируя обновленный сортер для чисел (все-таки вывел в самостоятельный алгоритм) - по окончательному времени сортировки если и есть разница, то несущественная (это я о сравнении итоговой производительности/скорости). Ваш обновленный вариант еще не тестировал.
Можно без мин-максов попытаться начать распределение, но тогда все сливки в виде равномерно распределенных целых чисел или дат будут пропущены и результат будет хуже. После ряда экспериментов выяснил, что делать ответный массив для распределения индексов равный высоте исходного или диапазону от минимума к максимуму не обязательно. Собственно чем больше массив для распределения, тем дольше идет это самое распределение. В общем достаточно 20%. Мелкие группы индексов добивать вставками, крупные рубить на части. Также замечено, что плавное изменение измерения массива при ReDim Preserve намного дольше, чем так называемое "авансовое" или скачкообразное. Методом научного тыка определил, что определение типа данных быстрее через VarType. --------- upd ------------ обновил файлик, в прошлом была ошибка. --------- upd ------------ Изменил систему первоначального распределения по типам данных. Попутно для сравнения на стенд добавил вариант "клевера" со старой системой дифференциации типов и связке AAF Sort + Clever на числах. Убрал нафиг глючный Excel sort со стенда. --------- upd ------------ Исправил ряд ошибок + стабилизировал по времени. Был разброс по малым (до 100000) массивам от долей секунды до полутора-двух секунд. Всему виной оказались числа с плавающей точкой с мизерным интервалом по значению...
В попытках превзойти связку сортера от AAF с моим распределителем по части текста написал пару альтернативных вариантов. Алгоритм 1 (LSD - по младшему разряду):
Скрытый текст
- массив текстовых значений из сортируемого столбца представляется в виде двумерного байтового массива - формируем первичный индексный массив - проходим по столбцу, разбиваем строки на коды символов (байты), формируем массив этих кодов/байтов - теперь от последнего столбца полученного массива к первому прогоняем все стринги в столбце через распределитель (на код/индекс каждого символа вешается цепочка индексов по столбцу, где этот символ фигурирует) - хвосты снизу вверх из распределительного массива собираются обратно в единый индексный массив - если столбец не первый, то все повторяем начиная с распределителя - т.е. по сути мультисортинг байтового массива по его индексам и не перезаписывая сам массив
Результат по времени
Скрытый текст
средненький - на 1,8 работает дольше AAF сортера, про связку вообще молчу. Скорость работы сильно зависит от максимальной длины тестового значения по сортируемому столбцу. Если на строки в пять символов время затрачивается примерно равное сортеру AAF, то на 10 уже коэф.1,8 и так по нарастающей. Плюс жрет много памяти. Но если не требуется особая точность и не нужно шерстить строку до последнего символа, то сойдет (в процедуру встроен ограничитель на глубину сортировки).
Вот собственно и код этого творения:
Скрытый текст
Код
Sub TextSort(mass(), ByVal n%, Optional ByVal dL% = 5)
Dim ll%, arr&(), arr1(), a&, i%, j%, k%, gg&(), xx&, x&, mtrx() As Byte, amtrx() As Byte
ReDim arr(LBound(mass, 1) To UBound(mass, 1))
For a = LBound(mass, 1) To UBound(mass, 1): arr(a) = a: Next
For a = LBound(arr) To UBound(arr)
k = Len(mass(arr(a), n))
If ll < k Then ll = k
Next
If ll > dL Then ll = dL
ReDim mtrx(LBound(arr) To UBound(arr), 0 To ll - 1)
For a = 1 To UBound(arr)
amtrx = StrConv(mass(arr(a), n), vbFromUnicode)
If UBound(amtrx) + 1 > ll Then i = ll - 1 Else i = UBound(amtrx)
For k = 0 To i: mtrx(a, k) = amtrx(k): Next
Next
For j = ll - 1 To 0 Step -1
ReDim arr1(0 To 255, 1 To 2)
For a = LBound(arr) To UBound(arr)
arr1(mtrx(arr(a), j), 1) = arr1(mtrx(arr(a), j), 1) + 1
Next
For a = LBound(arr) To UBound(arr)
If Not IsArray(arr1(mtrx(arr(a), j), 2)) Then
ReDim gg(1 To arr1(mtrx(arr(a), j), 1))
arr1(mtrx(arr(a), j), 2) = gg()
arr1(mtrx(arr(a), j), 2)(1) = arr(a)
arr1(mtrx(arr(a), j), 1) = 1
Else
arr1(mtrx(arr(a), j), 1) = arr1(mtrx(arr(a), j), 1) + 1
arr1(mtrx(arr(a), j), 2)(arr1(mtrx(arr(a), j), 1)) = arr(a)
End If
Next: x = LBound(arr)
For k = 0 To 255
If IsArray(arr1(k, 2)) Then For x1 = 1 To arr1(k, 1): arr(x) = arr1(k, 2)(x1): x = x + 1: Next
Next
Next
Erase mtrx
ReDim arr1(LBound(mass, 1) To UBound(mass, 1), LBound(mass, 2) To UBound(mass, 2))
For a = LBound(arr) To UBound(arr)
For i = LBound(mass, 2) To UBound(mass, 2)
arr1(a, i) = mass(arr(a), i)
Next: Next: Erase arr1: Erase gg
End Sub
Алгоритм 2 (MSD по старшему разряду):
Скрытый текст
- по примеру первого варианта создаем усечённый массив кодов/байтов (оптимальная ширина вычисляется, но не более 10, во вложенном файле проставлена ширина 8 ). Это нужно для дальнейшего считывания кода символа. Такой вариант работает быстрее Asc(Mid(string,n,1)) раза в два. - разбиваем содержимое сортируемого столбца по первым кодам символов - если количество элементов менее 50 (45-60, на больших количествах "вставки" работают медленнее, на меньших количество разбивок по следующему символу больше, и соотв.сортировка медленнее), то работают "вставки" - если больше 50, то дробим текущий массив строк по следующему символу с аналогичной проверкой - предыдущий шаг повторяется до тех пор, пока кол-во элементов не будет меньшим 50
Результат по времени:
Скрытый текст
- на коротких строках чуть медленнее сортировщика AAF - на длинных чуть быстрее оного - в любом варианте раза в полтора медленнее связки распределителя + сортера от AAF.
Код:
Скрытый текст
Код
Sub TextSortMSD(mass(), ByVal n%) 'предполагается, что входной массив начинается с 1
Dim arr&(), arr1(), a&, i%, j%, k%, gg&(), xx&, x&, mtrx() As Byte, amtrx() As Byte
Dim arr0(), Tree0(), st As String * 8, T3&, T0A&(), T1A&(), cc As Byte
T3 = UBound(mass, 1)
If T3 > 1 Then
ReDim arr(1 To T3): ReDim T0A(1 To T3): ReDim T1A(1 To T3)
ReDim mtrx(1 To T3, 0 To Len(st) - 1): xx = 1
For a = 1 To T3 'разбиваем строки на коды символов, создаем массив этих кодов
T0A(a) = a: arr(a) = a
st = mass(T0A(a), n): amtrx = StrConv(st, vbFromUnicode)
For k = 0 To UBound(amtrx): mtrx(a, k) = amtrx(k): Next
Next
ReDim arr1(32 To 255, 1 To 2)
For a = 1 To UBound(arr) 'первичная разбивка по кодам первых символов
arr1(mtrx(arr(a), 0), 1) = arr1(mtrx(arr(a), 0), 1) + 1
Next
For a = 1 To UBound(arr)
If Not IsArray(arr1(mtrx(arr(a), 0), 2)) Then
ReDim gg(1 To arr1(mtrx(arr(a), 0), 1))
gg(1) = arr(a): arr1(mtrx(arr(a), 0), 2) = gg()
arr1(mtrx(arr(a), 0), 1) = 1
Else
arr1(mtrx(arr(a), 0), 1) = arr1(mtrx(arr(a), 0), 1) + 1
arr1(mtrx(arr(a), 0), 2)(arr1(mtrx(arr(a), 0), 1)) = arr(a)
End If
Next
For k = 32 To 255
If arr1(k, 1) > 0 Then
If arr1(k, 1) > 50 Then
ReDim Tree0(1 To 2, 1 To 1): arr = arr1(k, 2): j = 1
txt0: ReDim arr0(32 To 255, 1 To 2)
For a = 1 To UBound(arr) 'очереднaя разбивка по коду следующего символа
arr0(mtrx(arr(a), j), 1) = arr0(mtrx(arr(a), j), 1) + 1
Next
For a = 1 To UBound(arr)
If Not IsArray(arr0(mtrx(arr(a), j), 2)) Then
ReDim gg(1 To arr0(mtrx(arr(a), j), 1))
gg(1) = arr(a): arr0(mtrx(arr(a), j), 2) = gg()
arr0(mtrx(arr(a), j), 1) = 1
Else
arr0(mtrx(arr(a), j), 1) = arr0(mtrx(arr(a), j), 1) + 1
arr0(mtrx(arr(a), j), 2)(arr0(mtrx(arr(a), j), 1)) = arr(a)
End If
Next
Tree0(1, j) = arr0: Tree0(2, j) = 32
txt1: For i = Tree0(2, j) To 255
If Tree0(1, j)(i, 1) > 0 Then
If Tree0(1, j)(i, 1) > 50 Then
cc = 0: dt = mass(T0A(Tree0(1, j)(i, 2)(1)), n) 'проверка на дубли
For a = 2 To Tree0(1, j)(i, 1)
If dt <> mass(T0A(Tree0(1, j)(i, 2)(a)), n) Then cc = 1: Exit For
Next
If cc = 0 Then
For a = 1 To Tree0(1, j)(i, 1): T1A(xx) = T0A(Tree0(1, j)(i, 2)(a)): xx = xx + 1: Next
GoTo txt2
End If
arr = Tree0(1, j)(i, 2): Tree0(2, j) = i: j = j + 1 'если индексов много, то уходим в рекурсию по их разбивке
If j > UBound(Tree0, 2) Then ReDim Preserve Tree0(1 To 2, j)
GoTo txt0
Else
If Tree0(1, j)(i, 1) = 1 Then T1A(xx) = T0A(Tree0(1, j)(i, 2)(1)): xx = xx + 1: GoTo txt2
T1A(xx) = T0A(Tree0(1, j)(i, 2)(1)): jj = xx 'вставки
For cc = 2 To Tree0(1, j)(i, 1)
xx = xx + 1: x = xx: dt = mass(T0A(Tree0(1, j)(i, 2)(cc)), n)
Do While mass(T1A(x - 1), n) > dt
T1A(x) = T1A(x - 1): x = x - 1
If x = jj Then Exit Do
Loop
T1A(x) = T0A(Tree0(1, j)(i, 2)(cc))
Next: xx = xx + 1
End If
End If
txt2: Next
If j > 1 Then
j = j - 1
For b = j To 1 Step -1
If Tree0(2, b) < 255 Then Tree0(2, b) = Tree0(2, b) + 1: j = b: GoTo txt1 'возвращаемся к началу
Next
End If
Else
If arr1(k, 1) = 1 Then T1A(xx) = T0A(arr1(k, 2)(1)): xx = xx + 1: GoTo txt00
T1A(xx) = T0A(arr1(k, 2)(1)): jj = xx 'вставки
For cc = 2 To arr1(k, 1)
xx = xx + 1: x = xx: dt = mass(T0A(arr1(k, 2)(cc)), n)
Do While mass(T1A(x - 1), n) > dt
T1A(x) = T1A(x - 1): x = x - 1
If x = jj Then Exit Do
Loop
T1A(x) = T0A(arr1(k, 2)(cc))
Next: xx = xx + 1
End If
End If
txt00: Next
Else
Exit Sub
End If
Erase mtrx: Erase Tree0
ReDim arr1(LBound(mass, 1) To UBound(mass, 1), LBound(mass, 2) To UBound(mass, 2))
For a = LBound(T1A) To UBound(T1A)
For i = LBound(mass, 2) To UBound(mass, 2)
arr1(a, i) = mass(T1A(a), i)
Next: Next: mass=arr1: Erase arr1
End Sub
------------ Маленький эксперимент - попытка скрестить "расчёску" и "вставки":
Скрытый текст
Код
Sub ttss()
Dim a&(), x&
ReDim a(1 To 100000)
For x = 1 To UBound(a)
a(x) = Rnd * 250000
Next
BSort a()
End Sub
Sub BSort(a&())
Dim j&, i&, n&, swp&, dt$, bb As Double, c&, cc As Double, b&(), x&, y&
n = UBound(a): j = n / 1.247: i = 1: b = a
bb = Timer
Do While j > 2
Do While i + j <= n
If b(i) > b(i + j) Then
swp = b(i): b(i) = b(i + j): b(i + j) = swp: c = c + 1
End If
i = i + 1
Loop
j = j / 1.247: i = 1
Loop
bb = Timer - bb
cc = Timer
i = 2: a(1) = b(1): y = 1
For j = i To n
x = i: i = i + 1
Do While a(x - 1) > b(j)
a(x) = a(x - 1): x = x - 1: c = c + 1
If x = y Then Exit Do
Loop
a(x) = b(j)
Next
cc = Timer - cc
Debug.Print "Расчёска: " & bb & " sec"
Debug.Print "Вставки: " & cc & " sec"
Debug.Print "Total: " & bb + cc & " sec"
End Sub
AAF, как писал один из критиков моих потугов на ниве сортерописания в этой теме: "Снимаю шляпу!". Ваш сортировщик лучший из симбионтов по части текста.
П.С.: По тексту откатил все почти в исходное состояние с мелкими коррективами. Немного модернизировал сортер AAF - вместо перезаписи в конце сортировки промежуточного индексного массива в исходный сделал запись в итоговый индексный массив. На доли секунды стало быстрее)
Изменения: - все субсортеры разнесены по отдельным процедурам - числовой сортер стал универсальным по положительным и отрицательным числам - даты отданы на обработку числовому сортеру
Что еще можно сделать: - продолжить модульную дифференциацию (в доп.к сборному универсальному сортеру добавить ряд процедур обрабатывающих только: числа, даты и текст без предварительного определения типов данных). Это сократит время на первичный анализ массива на типы данных в нем представленные. Но нужно заранее знать, что здесь те или иные типы. - переделать итоговую деиндексацию массива с целью сократить затраты по памяти. ----------- Обновил файл, в прошлом была серьезная ошибка. ----------- Ошибка была не одна... А точнее VBA своеобразно распознает вариантные даты и конвертирует их в числа. Даты отдал соотв.распределителю с досортировкой (если вдруг там будут не только даты, но и время) сортеру от AAF.
где в одномерном arr() - номер сортируемого столбца, направление сортировки (False - по возрастанию, True - по убыванию). Столбцов может быть несколько, но по каждому нужно указывать направление сортировки. Т.е. мульти сортинг. qwerty - сортируемый массив.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
06.02.2018 19:33:48
Jack Famous, если копнуть код, то можно легко заменить вводные параметры касательно направления сортировки. В коде за это отвечает переменная "d". Т.е. заменить булевы значения на 1/-1 например.
Пользователь
Сообщений: Регистрация: 18.12.2016
07.02.2018 03:45:05
Anchoret, в копилке в примере надо добавить End Sub
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
07.02.2018 05:52:03
AAF, я знаю) Торопился с утра перед работой, пытался втиснуться в рамки 100 кб, удалил ряд процедур с функциями и этот несчастный "End Sub"... Мне там доступ закрыт на редактирование. В этой теме рабочий вариант.
Тема сепарации оказалась весьма заразной (Спасибо Anchoret ). После тщетных попыток выбросить ее из головы, понял что единствый способ отвязаться что-нить нарисовать...
Цитата
Anchoret написал: По тексту откатил все почти в исходное состояние
Да, я тоже не нашел стабильного (универсального) решения и от сепарации по тексту решил отказаться вообще. Вот если б была функция, которая из n первых символов строки возвращала n-массив их кодов, вот тогда я б развернулся, кроме того сепарацию можно было сделать регулируемой в зависимости от характера данных. А я не знаю таких способов. Стандартными методами, типа, Asc(), AscW(), а если текстовое сравнение, то еще и UCase()... Все это напоминает шахту по добыче угля, где добытого угля более или менее хватает на отопление шахтерского поселка и то не факт. Вот если данные , то время потраченное на сепарацию можно считать убитым, но неотъемлемой частью времени потраченного на сортировку. Может быть есть другие пути..... Поэтому ограничился такой схемой сепаратора:
Код
Значение
Текст
Len(строки)=0
Len(строки)>0
Не текст
Empty
Не Empty (и вот для них один общий сепаратор на весь диапазон Double)
Кроме того обработал напильником свои ранее выложенные коды, что б поменьше смахивали на портянку, убрал косяки связанные с граничными условиями и добавил два новых параметра, позволяющими применить к сортировке участок индексов (по информации с сепаратора) не переписывая весь массив индексов. Вообщем вот код, а файл с генератором таблицы до 10 столбцов и строк до размера листа с генерацией числовых, текстовых и смешанных столбцов, а также с листом результатов, на котором можно созерцать вложенную сортировку выложу вечером.
Function DBound(a) As Integer
Dim u As Long, d As Integer: On Error Resume Next: Do: d = d + 1: u = UBound(a, d): Loop Until Err.Number > 0: DBound = d - 1
End Function
Function SortAll(a(), col, Optional aIdx, Optional orderSort, Optional compareMode)
Dim aC() As Long, a0() As Long, aO() As Integer, aM() As Integer, c As Long, o As Integer, cM As Integer
Dim a1() As Long, aK() As Long
Dim x, i As Long, j As Long, k As Long, l As Long
Dim i0 As Long, i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long
Dim aA(-632677 To 632675) As Long, eK As Long, sK As Long
Dim aAN1() As Long, aAN2() As Long, aAS1() As Long, aAS2() As Long, iIN As Long, iIS As Long
Dim aStr() As String
If DBound(a) <> 2 Then Exit Function 'обработка входных параметров''''''''''''''''''''''''''''''''''''''
If DBound(aIdx) = 1 Then a0 = aIdx Else ReDim a0(LBound(a) To UBound(a)): For i = LBound(a) To UBound(a): a0(i) = i: Next
If IsArray(col) Then
ReDim aC(1 To 1 + UBound(col) - LBound(col)): i = LBound(aC)
For Each x In col
If x >= LBound(a, 2) And x <= UBound(a, 2) Then aC(i) = x: i = i + 1
Next
ReDim Preserve aC(1 To i - 1)
Else
ReDim aC(1 To 1): If col >= LBound(a, 2) And col <= UBound(a, 2) Then aC(1) = col Else Exit Function
End If
i = 1: ReDim aO(1 To UBound(aC)): ReDim aM(1 To UBound(aC))
If IsArray(orderSort) Then
For Each x In orderSort
If x = -1 Then aO(i) = -1 Else aO(i) = 1
i = i + 1: If i > UBound(aC) Then Exit For
Next
x = aO(i - 1)
Else
If IsMissing(orderSort) Then x = 1 Else If orderSort = -1 Then x = -1 Else x = 1
End If
For i = i To UBound(aO): aO(i) = x: Next
i = 1
If IsArray(compareMode) Then
For Each x In compareMode
If x = 1 Then aM(i) = 1
i = i + 1: If i > UBound(aC) Then Exit For
Next
x = aM(i - 1)
Else
If IsMissing(compareMode) Then x = 0 Else If compareMode = 1 Then x = 1 Else x = 0
End If
For i = i To UBound(aM): aM(i) = x: Next
For j = UBound(aC) To 1 Step -1 'обработка по столбцам''''''''''''''''''''''''''''''''''''''''''
c = aC(j): o = aO(j): cM = aM(j)
ReDim aK(LBound(a0) To UBound(a0)): ReDim aStr(LBound(a) To UBound(a), c To c)
For i = LBound(a0) To UBound(a0) 'сепаратор'''''''''''''''''''''''''''''''''''''''''''
If VarType(a(a0(i), c)) = 8 Then
If Len(a(a0(i), c)) = 0 Then
aK(i) = -632676: i4 = i4 + 1
Else
aStr(a0(i), c) = a(a0(i), c): k = -632677: aK(i) = k: i3 = i3 + 1
End If
Else
If IsEmpty(a(a0(i), c)) Then
aK(i) = -632675: i5 = i5 + 1
Else
If a(a0(i), c) = 0 Then
i0 = i0 + 1
Else
x = a(a0(i), c)
If x > 0 Then
k = Int(Log(x) / Log(10)): k = Fix(x / 10 ^ (k - 2)) + k * 1000 + 324495
aK(i) = k: i2 = i2 + 1: aA(k) = aA(k) + 1
Else
k = Int(Log(-x) / Log(10)): k = Fix(x / 10 ^ (k - 2)) - k * 1000 - 324495
aK(i) = k: i1 = i1 + 1: aA(k) = aA(k) + 1
End If
End If
End If
End If
Next
ReDim aAN1(0 To Fix((i1 + i2) / 2)): ReDim aAN2(0 To UBound(aAN1))
ReDim aAS1(0 To Fix((i3) / 2)): ReDim aAS2(0 To UBound(aAS1))
'сборка после сепарации'''''''''''''''''''''''''''''''''''''''''''''''''''''''
k = LBound(a0): aA(0) = i0
If o = -1 Then
If i3 > 0 Then
l = i3: aA(-632677) = k: If l > 1 Then aAS1(iIS) = k: aAS2(iIS) = k + l - 1: iIS = iIS + 1
k = k + l
End If
If i4 > 0 Then aA(-632676) = k: k = k + i4
End If
For i = -632674 * o * Sgn(i1) To 632674 * o * Sgn(i2) Step o
If aA(i) > 0 Then
l = aA(i): aA(i) = k: If l > 1 Then aAN1(iIN) = k: aAN2(iIN) = k + l - 1: iIN = iIN + 1
k = k + l
End If
Next
If o = 1 Then
If i3 > 0 Then
l = i3: aA(-632677) = k: If l > 1 Then aAS1(iIS) = k: aAS2(iIS) = k + l - 1: iIS = iIS + 1
k = k + l
End If
If i4 > 0 Then aA(-632676) = k: k = k + i4
End If
If i5 > 0 Then aA(-632675) = k
'досортировка в результирующий массив индексов''''''''''''''''''''''''''''''''''''''''''''''''
ReDim a1(LBound(a0) To UBound(a0))
For i = LBound(a0) To UBound(a0): a1(aA(aK(i))) = a0(i): aA(aK(i)) = aA(aK(i)) + 1: Next
Erase aA: Erase aK: a0 = a1
If iIN > 0 Then
For i = 0 To iIN - 1
If aAN2(i) - aAN1(i) = 1 Then
If Sgn(a(a1(aAN1(i)), c) - a(a1(aAN2(i)), c)) = o Then a0(aAN1(i)) = a1(aAN2(i)): a0(aAN2(i)) = a1(aAN1(i))
Else
SortBin a, c, a0, o, aAN1(i), aAN2(i) 'досортировка не текста
End If
Next
End If
Erase a1: Erase aAN1: Erase aAN2: iIN = 0
If iIS > 0 Then SortStr aStr, c, a0, o, cM, aAS1(0), aAS2(iIS - 1) 'сортировка текста
Erase aAS1: Erase aAS2: Erase aStr: iIN = 0: iIS = 0: i0 = 0: i1 = 0: i2 = 0: i3 = 0: i4 = 0: i5 = 0
Next
ReDim aResult(LBound(a0) To UBound(a0), LBound(a, 2) To UBound(a, 2)) 'создание отсортированного массива данных
For j = LBound(a, 2) To UBound(a, 2)
For i = LBound(a0) To UBound(a0): aResult(i, j) = a(a0(i), j): Next
Next
aIdx = a0: Erase a0: SortAll = aResult
End Function
Sub SortBin(a(), ByVal c As Long, aIdx() As Long, Optional ByVal o As Integer, Optional ByVal b, Optional ByVal e)
Dim begin As Long, i As Long, i1 As Long, f1 As Long, v1 As Integer, v As Byte, a0() As Long
Dim endin As Long, j As Long, i2 As Long, f2 As Long, v2 As Integer, n As Long, a1() As Long, aF() As Long
If UBound(aIdx) = LBound(aIdx) Then Exit Sub
If IsMissing(b) Or IsMissing(e) Then
If o < 0 Then begin = UBound(aIdx): endin = LBound(aIdx): o = -1 Else begin = LBound(aIdx): endin = UBound(aIdx): o = 1
b = LBound(aIdx): e = UBound(aIdx)
Else
If b < e Then
If o < 0 Then begin = e: endin = b: o = -1 Else begin = b: endin = e: o = 1
Else
Exit Sub
End If
End If
ReDim a0(b To e): ReDim aF(1 To Fix(Abs(begin - endin) / 2 + 2)): n = 1: j = begin: aF(1) = begin: v = 1
For i = begin + o To endin Step o
If a(aIdx(i), c) < a(aIdx(i - o), c) Then
Select Case v
Case 1: v = 11: f1 = i - o: v1 = -o
Case 2: v = 12: f2 = i - o: v2 = -o
Case 21: v = 2: f1 = i - o
Case 22: v = 1: f2 = i - o: GoSub SLIV
End Select
Else
Select Case v
Case 1: v = 21: i1 = i - o: v1 = o
Case 2: v = 22: i2 = i - o: v2 = o
Case 11: v = 2: i1 = i - o
Case 12: v = 1: i2 = i - o: GoSub SLIV
End Select
End If
Next
Select Case v
Case 1: a0(j) = aIdx(j)
Case 11: For i1 = i - o To f1 Step -o: a0(j) = aIdx(i1): j = j + o: Next
Case 21: For i1 = i1 To i - o Step o: a0(j) = aIdx(i1): j = j + o: Next
Case 2: i2 = i - o: f2 = i - o: v2 = o: v = 0
Case 12: i2 = i - o: v = 0
Case 22: f2 = i - o: v = 0
End Select
If v > 0 Then n = n + 1: aF(n) = i Else GoSub SLIV
j = 2
For i = 2 To n - 1
If a(a0(aF(i)), c) < a(a0(aF(i) - o), c) Then aF(j) = aF(i): j = j + 1
Next
If j = 2 Then
For i = b To e: aIdx(i) = a0(i): Next: Erase a0: Exit Sub
End If
aF(j) = endin + o: n = j
Do While n > 3
ReDim Preserve aF(1 To n): a1 = a0: j = begin: n = 1
For i = 2 To UBound(aF) - 1 Step 2
i2 = aF(i)
Do Until a(a1(i2), c) < a(a1(j), c): j = j + o: Loop
a0(j) = a1(i2): j = j + o: i2 = i2 + o
For i1 = j - o To aF(i) - o Step o
For i2 = i2 To aF(i + 1) - o Step o
If a(a1(i2), c) < a(a1(i1), c) Then a0(j) = a1(i2): j = j + o Else Exit For
Next
a0(j) = a1(i1): j = j + o
Next
j = aF(i + 1): n = n + 1: aF(n) = j
Next
If i = UBound(aF) Then n = n + 1: aF(n) = endin + o
Loop
Erase a1: j = begin: i2 = aF(2): Erase aF
For i1 = j To i2 - o Step o
For i2 = i2 To endin Step o
If a(a0(i2), c) < a(a0(i1), c) Then aIdx(j) = a0(i2): j = j + o Else Exit For
Next
aIdx(j) = a0(i1): j = j + o
Next
For i2 = i2 To endin Step o: aIdx(j) = a0(i2): j = j + o: Next: Erase a0
Exit Sub
SLIV:
For i1 = i1 To f1 Step v1
For i2 = i2 To f2 Step v2
If a(aIdx(i2), c) < a(aIdx(i1), c) Then a0(j) = aIdx(i2): j = j + o Else Exit For
Next
a0(j) = aIdx(i1): j = j + o
Next
For i2 = i2 To f2 Step v2: a0(j) = aIdx(i2): j = j + o: Next: n = n + 1: aF(n) = i
Return
End Sub
Sub SortStr(a() As String, ByVal c As Long, aIdx() As Long, Optional ByVal o As Integer, Optional ByVal cM As Integer, Optional ByVal b, Optional ByVal e)
Dim begin As Long, i As Long, i1 As Long, f1 As Long, v1 As Integer, v As Byte, a0() As Long
Dim endin As Long, j As Long, i2 As Long, f2 As Long, v2 As Integer, n As Long, a1() As Long, aF() As Long
If UBound(aIdx) = LBound(aIdx) Then Exit Sub
If cM <> 1 Then cM = 0
If IsMissing(b) Or IsMissing(e) Then
If o < 0 Then
begin = UBound(aIdx): endin = LBound(aIdx): o = -1
Else
begin = LBound(aIdx): endin = UBound(aIdx): o = 1
End If
b = LBound(aIdx): e = UBound(aIdx)
Else
If b < e Then
If o < 0 Then
begin = e: endin = b: o = -1
Else
begin = b: endin = e: o = 1
End If
Else
Exit Sub
End If
End If
ReDim a0(b To e): ReDim aF(1 To Fix(Abs(begin - endin) / 2 + 2)): n = 1: j = begin: aF(1) = begin: v = 1
For i = begin + o To endin Step o
If StrComp(a(aIdx(i), c), a(aIdx(i - o), c), cM) = -1 Then
Select Case v
Case 1: v = 11: f1 = i - o: v1 = -o
Case 2: v = 12: f2 = i - o: v2 = -o
Case 21: v = 2: f1 = i - o
Case 22: v = 1: f2 = i - o: GoSub SLIV
End Select
Else
Select Case v
Case 1: v = 21: i1 = i - o: v1 = o
Case 2: v = 22: i2 = i - o: v2 = o
Case 11: v = 2: i1 = i - o
Case 12: v = 1: i2 = i - o: GoSub SLIV
End Select
End If
Next
Select Case v
Case 1: a0(j) = aIdx(j)
Case 11: For i1 = i - o To f1 Step -o: a0(j) = aIdx(i1): j = j + o: Next
Case 21: For i1 = i1 To i - o Step o: a0(j) = aIdx(i1): j = j + o: Next
Case 2: i2 = i - o: f2 = i - o: v2 = o: v = 0
Case 12: i2 = i - o: v = 0
Case 22: f2 = i - o: v = 0
End Select
If v > 0 Then n = n + 1: aF(n) = i Else GoSub SLIV
j = 2
For i = 2 To n - 1
If StrComp(a(a0(aF(i)), c), a(a0(aF(i) - o), c), cM) = -1 Then aF(j) = aF(i): j = j + 1
Next
If j = 2 Then
For i = b To e: aIdx(i) = a0(i): Next: Erase a0: Exit Sub
End If
aF(j) = endin + o: n = j
Do While n > 3
ReDim Preserve aF(1 To n): a1 = a0: j = begin: n = 1
For i = 2 To UBound(aF) - 1 Step 2
i2 = aF(i)
Do Until StrComp(a(a1(i2), c), a(a1(j), c), cM) = -1: j = j + o: Loop
a0(j) = a1(i2): j = j + o: i2 = i2 + o
For i1 = j - o To aF(i) - o Step o
For i2 = i2 To aF(i + 1) - o Step o
If StrComp(a(a1(i2), c), a(a1(i1), c), cM) = -1 Then a0(j) = a1(i2): j = j + o Else Exit For
Next
a0(j) = a1(i1): j = j + o
Next
j = aF(i + 1): n = n + 1: aF(n) = j
Next
If i = UBound(aF) Then n = n + 1: aF(n) = endin + o
Loop
Erase a1: j = begin: i2 = aF(2): Erase aF
For i1 = j To i2 - o Step o
For i2 = i2 To endin Step o
If StrComp(a(a0(i2), c), a(a0(i1), c), cM) = -1 Then aIdx(j) = a0(i2): j = j + o Else Exit For
Next
aIdx(j) = a0(i1): j = j + o
Next
For i2 = i2 To endin Step o: aIdx(j) = a0(i2): j = j + o: Next: Erase a0
Exit Sub
SLIV:
For i1 = i1 To f1 Step v1
For i2 = i2 To f2 Step v2
If StrComp(a(aIdx(i2), c), a(aIdx(i1), c), cM) = -1 Then a0(j) = aIdx(i2): j = j + o Else Exit For
Next
a0(j) = aIdx(i1): j = j + o
Next
For i2 = i2 To f2 Step v2: a0(j) = aIdx(i2): j = j + o: Next: n = n + 1: aF(n) = i
Return
End Sub
Изменено: - 02.03.2018 15:10:45
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
28.02.2018 14:21:49
Цитата
AAF написал: Вот если б была функция, которая из n первых символов строки возвращала n-массив их кодов, вот тогда я б развернулся, кроме того сепарацию можно было сделать регулируемой в зависимости от характера данных. А я не знаю таких способов.
Функция то есть, но она работает со всей строкой.
Код
ByteArr=StrConv(string,128)
На массиве строк 1кк 26 символов длиной на интелах обработка занимает порядка секунды. Моя домашняя AMDшка в два раза дольше обрабатывает. Можно конечно объявить строковую переменную с фиксированной длиной, но с фикс.строками VBA работает дольше. Эмпирическим путем было установлено, что такая конструкция работает не слишком долго:
Код
txt=arr(idx, n)
if len(txt)<4 then txt=txt & " "
ByteArr(StrConv(txt,128)
Есть даже функция по поиску вхождения байтового массива в другой байтовый массив - InStrB
Я пока отошел от темы мега сортеров по причине их непрактичности с точки зрения памяти. Потому как высокая скорость сортировки нужна на очень больших объемах данных. Последний из предложенных вариантов максимум мог работать с 10кк потом OutOfMemory. а на массивах до 100к хватает и досортировщика вроде этого:
Код
Sub ArrSort(mass(), ByVal n%)
Dim a&, b&, c&, i&, xx&, jj&, mm, x1&
Dim arr&(), arr0&(), sArr()
If UBound(mass, 1) < 2 Then Exit Sub
ReDim arr(1 To UBound(mass, 1))
ReDim arr0(1 To UBound(mass, 1)): xx = 1
For i = 1 To UBound(mass, 1): arr(i) = i: Next
b = UBound(mass, 1): c = b / 1.247331: i = 1
Do While c > 2
Do While i + c <= b
If mass(arr(i), n) > mass(arr(i + c), n) Then
x1 = arr(i): arr(i) = arr(i + c): arr(i + c) = x1
End If
i = i + 1
Loop
c = c / 1.247331: i = 1
Loop
jj = xx: arr0(xx) = arr(1)
For c = 2 To b
xx = xx + 1: x1 = xx
mm = mass(arr(c), n)
Do While mass(arr0(x1 - 1), n) > mm
arr0(x1) = arr0(x1 - 1): x1 = x1 - 1
If x1 = jj Then Exit Do
Loop
arr0(x1) = arr(c)
Next
ReDim sArr(1 To UBound(mass, 1), 1 To UBound(mass, 2))
For a = 1 To UBound(arr0)
For c = 1 To UBound(mass, 2)
sArr(a, c) = mass(arr0(a), c)
Next c
Next a: Erase arr: Erase arr0
mass = sArr: Erase sArr
End Sub
Изменено: - 28.02.2018 19:32:09
Пользователь
Сообщений: Регистрация: 18.12.2016
28.02.2018 14:51:13
Цитата
Anchoret написал: Я пока отошел от темы мега сортеров по причине их непрактичности с точки зрения памяти
Мегасортеры начинают меркнуть перед ресурсами сжираемыми мегаданными, особенно двумерными. Так что при увеличении размеров данных эффективность мегасортеров растет. И если компьютер загружен под завязку только исходным массивом, то это проблема уже не мегасортера, а, скорее частная ситуация. Да и потом я б свой сортер вряд ли назвал мега, хоть 10 лямов он достойно протянет (я еще проверю, но должен ) на 4Gb ОЗУ. Но все зависит от характера входных данных. А эффективность зачастую теряет в весе перед творческим интересом. Хотя мой интерес не только творческий, т. к. я обработку строю на таком методе сравнения данных и если я запущу в этот огород Excelсортер, то получу проблемы из-за своеобразного порядка сортировки последнего...
