Приветствую! Готовлю тестовый стенд для примера отсюда Сам новых функций не имею, так что тестеры приветствуются (Бахтиёр в деле)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Алексей, хоть условия задачи озвучь Потому что мое мнение - функции листа при равных условиях в большинстве случаев выигрывают в скорости против такого же функционала в VBA. Я про то, чтобы не получилось, что сравниваем скорость работы функций листа, вызванных из VBA против скорости встроенных в VBA возможностей. Здесь могут быть нюансы. Например, у нас используется в любом случае прослойка в виде application.worksheetfunction, для вызова которой VBA приходится общаться к сторонней библиотеке(Excel Object Library). У меня офис 365 и при наличии времени и интереса какие-то вещи могу потестировать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Дмитрий(The_Prist) Щербаков : сравниваем скорость работы функций листа, вызванных из VBA против скорости встроенных в VBA возможностей
именно это и сравниваем, чтобы понять, есть ли польза новых функций для VBA-разработки. Я думаю, что словари обойдут по скорости извлечения уникальных, а вот с сортировкой сложнее. Встроенных вариантов сортировки МАССИВА (на листе-пожалуйста) на VBA или нет или никуда не годятся. Буду использовать рекурсивный сортер 1x-массива в редакции от Anchoret (функции на его основе) — самый стабильный и универсальный вариант Разумеется, будет сравнение и с использованием супербиблиотеки от Виталия — чтобы в очередной раз показать удобство и скорость
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Добрый день. В диапазоне A1:D500000 данные (смотрите на скрине маленький кусок): Сам файл скину на файлообменник (11 Mb)
Макрос otbor_unikal: Отбор уникальных строк ПО ВСЕМУ МАССИВУ с охватом 4-х столбцов Вход: (1 to 500000, 1 to 4) Исход: (1 to 61719, 1 to 4) Время: 1,98 секунд Код:
Скрытый текст
Код
Sub otbor_unikal()
t = Timer
mas2 = WorksheetFunction.Unique(ActiveWorkbook.Sheets(1).Range("A1:D500000"))
Debug.Print Timer - t, "Отбор уникальных"
End Sub
Макрос sort_1_urovnevaya: Осуществляет ПО ВСЕМУ МАССИВУ 1-уровневую сортировку по возрастанию по 1-му столбцу Вход: (1 to 500000, 1 to 4) Исход: тот же размер Время: 1,54 секунд Код:
Скрытый текст
Код
Sub sort_1_urovnevaya()
t = Timer
mas2 = WorksheetFunction.Sort(Range("A1:D500000"))
Debug.Print Timer - t, "Одноуровневая сортировка"
End Sub
Макрос otbor_unikal_i_sort_4_urovnevaya: Осуществляет отбор уникальных с учётом 4-х столбцов и осуществляет 4-х уровневую сортировку по: 1) Сначала по 1-му столбцу - по возрастанию 2) Потом по 2-му столбцу - по убыванию 3) Потом по 3-му столбцу - по возрастанию 4) Потом по 4-му столбцу - по убыванию Вход: (1 to 500000, 1 to 4) Исход: (1 to 61719, 1 to 4) Время: 2,18 секунд Код:
Скрытый текст
Код
Sub otbor_unikal_i_sort_4_urovnevaya()
t = Timer
mas2 = WorksheetFunction.Sort(WorksheetFunction.Unique(Range("A1:D500000")), Array(1, 2, 3, 4), Array(1, -1, 1, -1))
Debug.Print Timer - t, "Отбор уникальных + 4-х уровневая сортировка"
End Sub
Начинайте отсчёт времени ПОСЛЕ mas=….Value Получение массива с листа является общей операцией для методов сравнения
Заодно можете кракозябры поправить при копировании с НЕпереключенной латиницей
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
не соглашусь, потому что рассматривается использование новых функций листа в VBA, а там мы работаем с массивами
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: а там мы работаем с массивами
ну это Ваши проблемы Функции-то могут работать и с диапазонами. Притом при вызове из VBA тоже. Поэтому все честно, в этом и соль. Надо же понимать, дает ли прирост в скорости такая передача параметра или наоборот.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Jack Famous, вы в изначальной теме в Курилке задавали вопрос насчёт того, что после удаления дубликатов вроде должно остаться всего 28 строк. Но это не так. Имеется ввиду удаление дубликатов строк с учётом значений всех 4-х столбцов. В таком случае, после удаления дубликатов из 500 тыс строк остаётся >60 тыс строк
ну если И с диапазонами, И с массивами, то согласен - так корректно
Цитата
Бахтиёр: Имеется ввиду удаление дубликатов строк с учётом значений всех 4-х столбцов
учёл — КЛЮЧОМ считается сцепка по 4ём столбцам
Отбор уникальных (сцепка по 4ём столбцам)
Код (shData — VBA-имя исходного листа с данными)
Код
Option Explicit
Option Private Module
'====================================================================================================
Public BV As New BedvitCOM.VBA ' https://bedvit.ru/xll/
'====================================================================================================
Sub UniqDic()
Dim dic As New Dictionary
Dim x, aAll, aOut()
Dim tx$, t!, r&, rr&, c&, cc&
aAll = shData.Range("A1:D500000").Value2
t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
For r = 1 To rr
tx = aAll(r, 1)
For c = 2 To cc
tx = tx & aAll(r, c)
Next c
If Not dic.Exists(tx) Then dic.Add tx, r
Next r
ReDim aOut(1 To dic.Count, 1 To cc): r = 0
For Each x In dic.Items
r = r + 1
For c = 1 To cc
aOut(r, c) = aAll(x, c)
Next c
Next x
Debug.Print Timer - t, "UniqDic", UBound(aOut, 1) ' 2.02 sec / 61 719 rows
Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(UBound(aOut, 1), cc).Value2 = aOut
End Sub
'====================================================================================================
'====================================================================================================
Sub UniqBedvit()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut(), aRows() As Long
Dim tx$, t!, r&, rr&, c&, cc&, u&
aAll = shData.Range("A1:D500000").Value2
t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
ReDim aRows(1 To rr)
For r = 1 To rr
tx = aAll(r, 1)
For c = 2 To cc
tx = tx & aAll(r, c)
Next c
If map.Insert(tx, 0) Then u = u + 1: aRows(u) = r
Next r
ReDim aOut(1 To u, 1 To cc)
For r = 1 To u
For c = 1 To cc
aOut(r, c) = aAll(aRows(r), c)
Next c
Next r
Debug.Print Timer - t, "UniqBedvit", u ' 1.63 sec / 61 719 rows
Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(u, cc).Value2 = aOut
End Sub
'====================================================================================================
Sub UniqBedvitTranspose()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut
Dim tx$, t!, r&, rr&, c&, cc&, u&
aAll = shData.Range("A1:D500000").Value2
t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
ReDim aOut(1 To cc, 1 To rr) ' Array-reverse for ReDim Preserve
For r = 1 To rr
tx = aAll(r, 1)
For c = 2 To cc
tx = tx & aAll(r, c)
Next c
If map.Insert(tx, 0) Then
u = u + 1
For c = 1 To cc
aOut(c, u) = aAll(r, c)
Next c
End If
Next r
ReDim Preserve aOut(1 To cc, 1 To u)
BV.Transpose aOut
Debug.Print Timer - t, "UniqBedvit", u ' 1.69 sec / 61 719 rows
Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(u, cc).Value2 = aOut
End Sub
'====================================================================================================
Результаты и выводы
2,02 — VBA, 1.63 или 1.69 (в зависимости от способа) — bedvit Основная проблема: ReDim Preserve не позволяет "обрезать" пустые "строки" массива — только "столбцы" и из-за этого приходится пересобирать новый
Бахтиёр, жду ваших замеров по моему коду - должно быть быстрее, чем у меня
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Бахтиёр: Ваш код - 1,18 секунд…Мой результат - 1,98 секунд
отрыв более 40% — и это без супербуста от Виталия (там раза в 3 отрыв будет)
Цитата
Бахтиёр: там кажется сначала нужно установить нужно кое-что
скачать с его сайта бесплатную надстройку (ссылку я в коде указал) и установить
Интересно, что прямая передача диапазона для новой функции ускоряет процесс
Цитата
Бахтиёр: Удивлюсь, если обойдёте и по 4-х уревневой сортировке
ну с библой от Виталия у вас точно шансов нет, а вот без неё придётся выкручиваться
В любом случае, новый движок мне нравится - обычно функции листа проигрывают намного сильнее Пара строк кода и вы делаете то же самое, для чего мне пришлось использовать годы опыта в программировании - это впечатляет, конечно Радует (как человека, потратившего время на изучение) только, что скорость пока хуже
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: Интересно, что прямая передача диапазона для новой функции ускоряет процесс
вполне прогнозируемо, т.к. в таком случае в функцию идет прямая передача данных из памяти, без доп.преобразований с нашей стороны. Все преобразования к массиву в случае необходимости будут произведены самой функцией. Именно поэтому я и написал попробовать это сделать.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Дмитрий(The_Prist) Щербаков: в таком случае в функцию идет прямая передача данных из памяти, без доп.преобразований с нашей стороны
я бы понял, если бы мы УЧИТЫВАЛИ время получения массива из диапазона (типа функция сделает это быстрее), но мы, как я понял, не учитываем, а значит "готовый" массив ей не нравится и она ещё как-то его должна "приготовить"
Может быть попробовать переменную вариативного массиваmas() вместо просто вариативной mas?…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit, да знаю я - изучаю) В твоём работает, а переношу в новый - не робит) Завтра отпишусь тебе утром)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
БМВ, я так понимаю, это и уникальные и сортировка? Что-то пошло не так, т.к. выгружено в 2 раза (чуть больше, чем в 2: 30 817 вместо 61 719) МЕНЬШЕ строк
Код для раннего связывания
Код
Sub ADOunic()
Dim ADO_RS As New ADODB.Recordset, ADO_C As New ADODB.Connection
Dim arr, aOut(), q$, q2$, t!, r&, c&
t = Timer
q = "[" & shData.Name & "$A:D]"
q = "SELECT DISTINCT * FROM " & q & "ORDER BY F1,F2 DESC ,F3,F4 DESC"
q2 = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=NO"";"
ADO_C.Open q2: ADO_RS.Open q, ADO_C
arr = ADO_RS.GetRows
Debug.Print "Main", Format$(1000 * (Timer - t), "0 ms") ' 0.54 sec
t = Timer
ReDim aOut(1 To UBound(arr, 2) + 1, 1 To UBound(arr, 1) + 1)
For r = 1 To UBound(aOut, 1)
For c = 1 To UBound(aOut, 2)
aOut(r, c) = arr(c - 1, r - 1)
Next c
Next r
Debug.Print "Trns", Format$(1000 * (Timer - t), "0 ms") ' 0.01 sec (12 ms)
t = Timer
Worksheets.Add After:=ActiveSheet
Cells(1, 1).Resize(UBound(aOut, 1), UBound(aOut, 2)).Value2 = aOut ' 0.14 sec / 30 817 rows
Debug.Print "Out", Format$(1000 * (Timer - t), "0 ms"), Format$(UBound(aOut, 1), "#,##0 el")
End Sub
Время, конечно, впечатляет — в 2 раза быстрее супербиблы и в 3 раза быстрее штатных словарей. Осталось разобраться с корректностью и замерить снова Есть, конечно, неудобство в том, что нужно транспонировать массив и границы в нём от нолей, но решается очень быстро (12 миллисекунд)
Изменено: Jack Famous - 23.09.2021 10:49:29(Изменил код и текст с учётом получения массива (пост БМВ ниже))
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Дополнил предыдущее сообщение с учётом получения массива. Остаётся главная проблема - НЕ ТО количество строк
И ещё: дядь Миш, а можно работать ADO с массивами или только с диапазонами? Хочу сформировать массив сам и передать в ADO - мне нравится такая скорость. Если можно, то я тему отдельную создам
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
по поводу результата, нужно проверять. сравнить что там не входит в результат. Может ограничения ADO вылезают какие. сделай на источнике в 65000 строк и сравни рез.
мда…вот из-за таких "может быть", я его и не использую Нам нужно полмиллиона обрабатывать, поэтому, к сожалению, дисквалификация по причине невыполнения условий
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
БМВ, я бы поборолся ещё, если бы знал, а так точно не вариант)) Ну допустим, поймём мы, в чём проблема, исправим, а где гарантия, что дальше такого не повторится? Такой ненадёжный инструмент мне не нужен
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Option Explicit
Option Private Module
'====================================================================================================
Sub ADO()
Dim ADO_RS As New ADODB.Recordset, ADO_C As New ADODB.Connection
Dim arr, aOut(), q$, q2$, t!, r&, c&
t = Timer
q = "[" & shData.Name & "$A:D]"
q = "SELECT DISTINCT * FROM " & q & "ORDER BY F1,F2 DESC ,F3,F4 DESC"
q2 = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=NO"";"
ADO_C.Open q2: ADO_RS.Open q, ADO_C
arr = ADO_RS.GetRows
Debug.Print "Main", Format$(1000 * (Timer - t), "0 ms") ' 0.54 sec
t = Timer
ReDim aOut(1 To UBound(arr, 2) + 1, 1 To UBound(arr, 1) + 1)
For r = 1 To UBound(aOut, 1)
For c = 1 To UBound(aOut, 2)
aOut(r, c) = arr(c - 1, r - 1)
Next c
Next r
Debug.Print "Trns", Format$(1000 * (Timer - t), "0 ms") ' 0.01 sec (12 ms)
t = Timer
ArrOut aOut ' 0.14 sec / 30 817 rows
Debug.Print "Out", Format$(1000 * (Timer - t), "0 ms"), Format$(UBound(aOut, 1), "#,##0 el")
End Sub
Sort
Код
Option Explicit
Option Private Module
'====================================================================================================
'====================================================================================================
Sub TestSort_1Recur()
Dim aAll, aOut(), aVal(), aInd() As Long
Dim t1!, t2!, t3!, tt!, r&, c&
ArrGet aAll
t1 = Timer
ReDim aVal(1 To UBound(aAll, 1)): ReDim aInd(1 To UBound(aVal))
For r = 1 To UBound(aAll, 1)
aVal(r) = aAll(r, 1): aInd(r) = r
Next r
t1 = Timer - t1 ' 63 ms
t2 = Timer
Sort1dRecurWithInd aVal, aInd, 1, UBound(aInd)
t2 = Timer - t2 ' 1 172 ms
t3 = Timer
ReDim aOut(1 To UBound(aAll, 1), 1 To UBound(aAll, 2))
For r = 1 To UBound(aInd)
For c = 1 To UBound(aAll, 2)
aOut(r, c) = aAll(aInd(r), c)
Next c
Next r
t3 = Timer - t3 ' 344 ms. Total: 1.58 sec
Debug.Print "Prepare", Format$(1000 * t1, "0 ms")
Debug.Print "Sort", Format$(1000 * t2, "0 ms")
Debug.Print "ReBuild", Format$(1000 * t3, "0 ms")
Debug.Print "Total", Format$((t1 + t2 + t3), "0.00 sec")
ArrOut aOut
End Sub
'====================================================================================================
'====================================================================================================
Sub TestSort_1Sheet()
Dim t!
t = Timer
shData.Copy after:=ActiveSheet
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1:A500000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:D500000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Debug.Print "Sort", Format$(Timer - t, "0.00 sec") ' 2.1 sec
End Sub
'----------------------------------------------------------------------------------------------------
Sub TestSort_4Sheet()
Dim t!
t = Timer
shData.Copy after:=ActiveSheet
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1:A500000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("B1:B500000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("C1:C500000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("D1:D500000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange Range("A1:D500000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Debug.Print "Sort", Format$(Timer - t, "0.00 sec") ' 2.8 sec
End Sub
'====================================================================================================
'====================================================================================================
Sub TestSort_1Bedvit()
Dim aAll, t!
ArrGet aAll
t = Timer
BV.ArraySortV aAll
Debug.Print "bedvit", Format$(1000 * (Timer - t), "0 ms") ' 200 ms
ArrOut aAll
End Sub
Uniq
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub UniqDic()
Dim dic As New Dictionary
Dim x, aAll, aOut()
Dim tx$, t!, r&, rr&, c&, cc&
ArrGet (aAll): t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
For r = 1 To rr
tx = aAll(r, 1)
For c = 2 To cc
tx = tx & aAll(r, c)
Next c
If Not dic.Exists(tx) Then dic.Add tx, r
Next r
ReDim aOut(1 To dic.Count, 1 To cc): r = 0
For Each x In dic.Items
r = r + 1
For c = 1 To cc
aOut(r, c) = aAll(x, c)
Next c
Next x
Debug.Print Timer - t, "UniqDic", UBound(aOut, 1) ' 2.02 sec / 61 719 rows
ArrOut aOut
End Sub
'====================================================================================================
'====================================================================================================
Sub UniqBedvit()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut(), aRows() As Long
Dim tx$, t!, r&, rr&, c&, cc&, u&
ArrGet aAll: t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
ReDim aRows(1 To rr)
For r = 1 To rr
tx = aAll(r, 1)
For c = 2 To cc
tx = tx & aAll(r, c)
Next c
If map.Insert(tx, 0) Then u = u + 1: aRows(u) = r
Next r
ReDim aOut(1 To u, 1 To cc)
For r = 1 To u
For c = 1 To cc
aOut(r, c) = aAll(aRows(r), c)
Next c
Next r
Debug.Print Timer - t, "UniqBedvit", u ' 1.63 sec / 61 719 rows
ArrOut aOut
End Sub
'====================================================================================================
Sub UniqBedvitTranspose()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut
Dim tx$, t!, r&, rr&, c&, cc&, u&
ArrGet aAll: t = Timer
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
ReDim aOut(1 To cc, 1 To rr) ' Array-reverse for ReDim Preserve
For r = 1 To rr
tx = aAll(r, 1)
For c = 2 To cc
tx = tx & aAll(r, c)
Next c
If map.Insert(tx, 0) Then
u = u + 1
For c = 1 To cc
aOut(c, u) = aAll(r, c)
Next c
End If
Next r
ReDim Preserve aOut(1 To cc, 1 To u)
BV.Transpose aOut
Debug.Print Timer - t, "UniqBedvit", u ' 1.69 sec / 61 719 rows
ArrOut aOut
End Sub
WORK
Код
Option Explicit
Option Private Module
'====================================================================================================
Public BV As New BedvitCOM.VBA ' https://bedvit.ru/xll/
'====================================================================================================
Sub ArrGet(arr)
arr = shData.Range("A1:D500000").Value2
End Sub
'====================================================================================================
Sub ArrOut(arr, Optional iRows&, Optional iColumns&)
If iRows = 0 Then iRows = UBound(arr, 1) - LBound(arr, 1) + 1
If iColumns = 0 Then iColumns = UBound(arr, 2) - LBound(arr, 2) + 1
Worksheets.Add after:=ActiveSheet
Cells(1, 1).Resize(iRows, iColumns).Value2 = arr
End Sub
'====================================================================================================
Sub Sort1dRecurWithInd(arrVal(), arrInd() As Long, l&, u&)
Dim x, y, n&, i&, j&
i = l: j = u: x = arrVal((l + u) \ 2)
Do
Do While arrVal(i) < x: i = i + 1: Loop
Do While x < arrVal(j): j = j - 1: Loop
If i <= j Then
y = arrVal(i): arrVal(i) = arrVal(j): arrVal(j) = y
n = arrInd(i): arrInd(i) = arrInd(j): arrInd(j) = n
i = i + 1: j = j - 1
End If
Loop Until i > j
If l < j Then Sort1dRecurWithInd arrVal, arrInd, l, j
If i < u Then Sort1dRecurWithInd arrVal, arrInd, i, u
End Sub
Результаты и выводы
Уникальные
Словари заметно быстрее новых функций, а bedvit кратно быстрее словарей (ну это и так было понятно) Также нужно учитывать, что количество ключей не повлияет на скорость bedvit'а, а вот словари после 100 тыс КЛЮЧЕЙ начнут задыхаться Как себя поведут функции листа, я не знаю и предлагаю вам затестить это в профильной теме
Сортировка
Вот тут проблемка Сортер от bedvit'а позволяет сортировать только 3 поля (мне, кстати всегда этого хватало), а отсортировать сначала 2-4, а потом 1ый столбец в 2 прохода не получится, т.к. переданный порядок не сохраняется при новой сортировке (мы сейчас обсуждаем этот момент)
Сортировка ОДНОГО столбца у bedvit'а занимает 0,2 сек, что в РАЗЫ быстрее новых функций (даже без учёта того, что у вас будет ещё быстрее) Сортировка ОДНОГО столбца с помощью рекурсивной функции занимает 1,6 сек (заметно быстрее, чем нвые функции и у на вашей машине будет ещё быстрее) Сортировка ОДНОГО столбца на листе занимает 2,1 сек (быстрее, но ненамного) Сортировка 4ёх столбцов на листе занимает 2,8 сек - должно быть быстрее, чем у вас, но это НА ЛИСТЕ, что далеко не всегда удобно
В целом
Ещё раз подчеркну, что новые функции мне очень понравились. Постараюсь внедрить в работу, как только они выйдут. И как раз не для VBA, а для общего удобства работы пользователей и скорости нового движка. В VBA библа Виталия по-прежнему всех уделает (к тому же, он её постоянно дорабатывает), а вызывать её не сложнее и не длиннее, чем новые функции, поэтому новые функции в разрезе "для VBA" - это для тех, кто стесняется использовать по-настоящему мощные игрушки (а это, к сожалению, все, кроме нас с Виталием)
Изменено: Jack Famous - 27.09.2021 11:07:09(Корректировка логических ошибок)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Есть один ньюанс. Если начать отсчёт времени ПЕРЕД получением значения диапазона ячеек в переменную массива (mas=Range(...).Value) --> время работы кода (VBA инструменты) будет увеличено. А если начать ПОСЛЕ ..., то ---> время работы будет меньше.
А с WorksheetFunction как бы наоборот: Такая структура:
Код
Sub ddd()
mas=Range(...).Value
t=Timer
mas2=WorksheetFunction,Sort(mas)...
...
End Sub
работает медленнее,
А такая:
Код
Sub ddd()
t=Timer
mas2=WorksheetFunction.Sort(Тут сразу диапазон)
...
End Sub
быстрее.
И на вчерашнем тестировании, и сегодня вы как бы сравниваете два кода, когда в вашем коде начало отсчёта начинается после mas=Range(...).Value, то есть высчитывается время ушедшее только на сортировку, а с WorksheetFunction время идёт и на получение данных.
Если я смог правильно объяснить, и если вы согласны с этим, ИМХО будет правильнее и в ваших кодах тоже учесть время на получение данных в массив.
Я правильно понимаю, что не будет кода на 4-х уровневую сортировку инструментами VBA? А любопытно, с рекурсивной функцией можно сделать 2-х ли 3-х уровневую сортировку? Интересное наблюдение: функции листа СОРТ() И УНИК() ни на листе, ни на коде не работают с одномерными массивами, а вот ФИЛЬТР() работает.
Изменено: Бахтиёр - 23.09.2021 14:49:23(добавил дополнительные вопросы)
Бахтиёр: будет правильнее и в ваших кодах тоже учесть время на получение данных в массив
не согласен - при тестировании РАБОТЫ, время ПОЛУЧЕНИЯ ДАННЫХ учитываться не должно. Если вам быстрее передавать без массива, то, разумеется, вы можете так делать, но приводить к этому и мои способы — нельзя
Цитата
Бахтиёр: не будет кода на 4-х уревневую сортировку инструментами VBA?
есть пример штатной сортировки диапазона на листе: Sub TestSort_4Sheet()
Цитата
Бахтиёр: СОРТ() И УНИК() не на листе, не на коде не работают с одномерными массивами
возможно, вы просто не умеете их готовить может есть функция из новых для преобразования или попробуйте поэкспериментировать с нижними границами. Как не работает - можно пример?
Меня, как всегда, библа Виталия выручает - она это реально МГНОВЕННО делает
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄