потому что WorkSheetFunction.Transpose() сделает из одномерного массива двумерный столбец с нижней границей 1 Учтите, что самописная функция будет быстрее и надёжнее штатной
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
БМВ, тогда спасибо просто за вариант тебе и старшему товарищу Андрею VG
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
TestSort_1Recur() вроде работает неправильно. Смотрите скрин, там стрелкой указано, из какого массива получился какой массив. Разве при одноуровневой сортировке результат не должен быть таким, как на таблице, покрашенной на желтый цвет?
Бахтиёр: при одноуровневой сортировке результат не должен быть таким, как на таблице
нет При такого рода сортировке, гарантируется только сортировка указанного столбца, а порядок остальных столбцов не сохраняется (не гарантируется). Не путать с нарушением построчной связи - этого не происходит
Собственно, я её обычно использую для сортировки уникальных данных и этой проблемы не наблюдаю Можно 1 раз отсортировать данные как надо на листе, сделать столбец с целочисленной нумерацией согласно подходящей сотрировки и кодом в памяти просто сортировать по этому одному столбцу. Это очень быстро
Есть ещё нюансы в VBA-вариантах рекурсии или bedvit'a - там используется сортировка по символам UniCode, то есть "истинная" сортировка с различием регистра и правильным отношением к пустым элементам (в начале, а не конце) и букве ё - она будет НЕ ПОСЛЕ "е" То что мы привыкли считать "нормальной" сортировкой (по алфавиту + пустые в конце + по-умолчанию игнорируется регистр, но можно изменить) — не более, чем одна из многих реализаций "настоящей" сортировки, представленной bedvit'ом
Чтобы нивелировать данный нюанс у себя, Виталий как раз и сделал возможным сортировку ВСЕХ столбцов (процедура сейчас тестируется)
В заключение: При "истинной" сортировке можно смело использовать невероятно быстрый бинарный поиск, а при любой другой — нет
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Бахтиёр: ...насчёт одномерных массивов... =УНИК({3;8;8}) на листе не удаляет дубликаты =СОРТ({4;1;8}) на листе не сортирует то же самое и с кодами VBA:
Код
Sub ddd()
arr=Array(4,7,1,7)
arr2=WorksheetFunction.Sort(arr)
arr3=WorksheetFunction.Unique(arr)
End Sub
У этих функций есть необязательный аргумент - "По столбцам". Вот его и нужно исползовать, чтобы работало с 1-мерными массивами, ведь 1-мерные массивы как бы "горизонтальные", поэтому по отношению к ним нужно указать этот необязательный аргумент:
=УНИК({3;8;8},ИСТИНА) =СОРТ({4;1;8},,,ИСТИНА)
Код
Sub ddd()
arr=Array(4,7,1,7)
arr2=WorksheetFunction.Sort(arr,,,True)
arr3=WorksheetFunction.Unique(arr,True)
End Sub
Цитата
БМВ: С учетом того что нельзя ограничить диапазон и медленной работой - рассматривать не стоит. разве что при работе с закрытыми книгами.
Кстати, новые функции умеют работать на листе с закрытыми книгами.
Бахтиёр: У этих функций есть необязательный аргумент - "По столбцам"
ну вот видите - всё сразу стало намного проще
Цитата
Бахтиёр: новые функции умеют работать на листе с закрытыми книгами
так а сейчас как? Я могу сослаться из одной книги в другую и в ней всегда будут актуальные данные - разве нет?
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
например, СУММЕСЛИМН не работает с закрытой книгой СУММПРОИЗВ работает. Я хотел сказать, что новые функции тоже работают как СУММПРОИЗВ, то есть если закрыть базовую книгу, откуда формулы тянут данные, ячейки не станут #ЗНАЧ! как в случае с СУММЕСЛИМН
Бахтиёр, так как я не использую формулы для таких связей, то пришлось моделировать … Действительно, неудобно — выдаёт ошибку на СУММЕСЛИ() при закрытии источника. Если это поправили (вы именно ЭТО имели ввиду), то очень хорошо
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Нет, как бы не поправили: 1) Есть функции, которые не тянут (изначально, до сих пор, да и в будущем ИМХО) данные из закрытых книг: СУММЕСЛИМН, СЧЁТЕСЛИМН, ДВССЫЛ 2) И есть другие, которые тянут данные из закрытых книг.
Хорошо, что новые 365-овские (СОРТ, УНИК, ФИЛЬТР, ...) сделали умеющими работать с закрытой книгой
Бахтиёр, понял: старые не адаптировали, так хоть новые не зафаршмачили Может, поправят в будущем, когда идеи для обновлений (за что платить подписчикам) кончатся
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Оттестировал новую сортировку и остался очень доволен
Модуль «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!, tt!, r&, rr&, c&, cc&, u&
t = Timer
ArrGet aAll: rr = UBound(aAll, 1): cc = UBound(aAll, 2)
t = Timer - t: Debug.Print t, "Prepare" ' 0.11
t = Timer
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
t = Timer - t: tt = tt + t: Debug.Print t, "GetUniq" ' 1.59
t = Timer
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
t = Timer - t: tt = tt + t: Debug.Print t, "reBuild" ' 0.03
t = Timer
ArrOut aOut
t = Timer - t: Debug.Print t, "Out" ' 0.26
Debug.Print tt, "Main", Format$(u, "#,##0") ' 1.63 / 61 719
End Sub
'====================================================================================================
Sub UniqBedvitTranspose()
Dim map As New BedvitCOM.UnorderedMap
Dim x, aAll, aOut
Dim tx$, t!, tt!, r&, rr&, c&, cc&, u&
t = Timer
ArrGet aAll
rr = UBound(aAll, 1): cc = UBound(aAll, 2)
t = Timer - t: Debug.Print t, "Prepare" ' 0.01
t = Timer
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
t = Timer - t: tt = tt + t: Debug.Print t, "1. reBuild" ' 1.64
t = Timer
ReDim Preserve aOut(1 To cc, 1 To u)
t = Timer - t: tt = tt + t: Debug.Print t, "2. ReDim Preserve" ' 0.05
t = Timer
BV.Transpose aOut
t = Timer - t: tt = tt + t: Debug.Print t, "3. Transpose" ' 0.01
t = Timer
ArrOut aOut
t = Timer - t: Debug.Print t, "Out" ' 0.29
Debug.Print tt, "Main", Format$(u, "#,##0") ' 1.69 / 61 719
End Sub
Модуль «Sort». Добавлена сортировка по 4ём столбцам (0,7 сек)
Код
Option Explicit
Option Private Module
'====================================================================================================
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
'====================================================================================================
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_4Bedvit()
Dim aAll, t!
ArrGet aAll
t = Timer
BV.ArraySortV aAll, 1, , 2, 1, 3, , "4,1"
Debug.Print "bedvit", Format$(1000 * (Timer - t), "0 ms") ' 688 ms
ArrOut aAll
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
Модуль «All». Uniq + Sort (всё вместе за 1,03 сек)
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub TestAll_BedvitDicSort()
Dim map As New BedvitCOM.UnorderedMap
Dim aAll, aOut, aRows() As Long
Dim tx$, t!, tt!, r&, rr&, c&, cc&, u&
t = Timer
ArrGet aAll: rr = UBound(aAll, 1): cc = UBound(aAll, 2)
t = Timer - t: Debug.Print t, "Prepare" ' 0.08
t = Timer
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
t = Timer - t: tt = tt + t: Debug.Print t, "1. GetUniq" ' 1.61
t = Timer
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
t = Timer - t: tt = tt + t: Debug.Print t, "2. reBuild" ' 0.03
t = Timer
BV.ArraySortV aOut, 1, 0, 2, 1, 3, 0, "4,1"
t = Timer - t: tt = tt + t: Debug.Print t, "3. Sort" ' 0.06
t = Timer
ArrOut aOut
t = Timer - t: Debug.Print t, "Out", Format$(u, "#,##0") ' 0.28 / 61 719
Debug.Print tt, "Main Time" ' 1.71
End Sub
'====================================================================================================
Sub TestAll_BedvitSortOnly()
Dim x, aAll, aOut, f As Boolean
Dim tx$, t!, tt!, r&, rr&, c&, cc&, u&
t = Timer
ArrGet aAll: rr = UBound(aAll, 1): cc = UBound(aAll, 2)
t = Timer - t: Debug.Print t, "Prepare" ' 0.09
t = Timer
BV.ArraySortV aAll, 1, 0, 2, 1, 3, 0, "4,1"
t = Timer - t: tt = tt + t: Debug.Print t, "1. Sort" ' 0.67
t = Timer
ReDim aOut(1 To cc, 1 To rr) ' reverse array
For c = 1 To cc ' fill 1st row (reverse col)
aOut(c, 1) = aAll(1, c)
Next c
u = 1 ' counter for new rows
For r = 2 To rr
For c = 1 To cc
If aAll(r, c) <> aAll(r - 1, c) Then f = True: Exit For
Next c
If f Then
f = False: u = u + 1
For c = 1 To cc
aOut(c, u) = aAll(r, c)
Next c
End If
Next r
t = Timer - t: tt = tt + t: Debug.Print t, "2. reBuild" ' 0.31
t = Timer
BV.Transpose aOut
t = Timer - t: tt = tt + t: Debug.Print t, "3. Transpose" ' 0.04
t = Timer
ArrOut aOut
t = Timer - t: Debug.Print t, "Out", Format$(u, "#,##0") ' 1.57
Debug.Print tt, "Main Time", Format$(u, "#,##0") ' 1.03 / 61 719
End Sub
Сортировка оказалась настолько хороша, что даже нет необходимости использовать карты (быстрая замена словарей) — сортировка 500 тыс строк и 4ёх столбцов оказалась быстрее, чем извлечение уникальных + сортировка 60 тыс строк Подробности можно увидеть по закомментированому таймингу этапов
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄