Получение списка уникальных значений из одномерного массива VBA
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
03.03.2019 08:20:27
Собственно это очередной тест драйв по скорости... ------------- Сравнивались (отбор уникальных среди целых чисел): - собственная процедура - ArrayList (самый тормозной) - Dictionary - Collection - Hashtable (System.Collections.Hashtable) сравнение не совсем корректное, т.е. процедура выдает сразу массив с уникальными значениями, а все объекты только наполнялись. --------------- Результат теста (числа):
Sub zxzxzx()
Dim a&, b&, c&, arr(), dd, tt#, AL As Object, DC As Object, COL As New Collection, HT As Object
x = 500000: Randomize
For c = 10000 To x Step x / 10
ReDim arr(1 To c)
For a = 1 To c
b = Rnd * c: arr(a) = b 'TextGen arr(a), 10, 10 'b = Rnd * c: arr(a) = b
Next
Set DC = CreateObject("Scripting.Dictionary")
Set AL = CreateObject("System.Collections.ArrayList")
Set HT = CreateObject("System.Collections.Hashtable")
'---UniList---
tt = Timer
UniList arr(), dd
tt = Timer - tt: Debug.Print "Array * " & c & " UniList Time: " & Format(tt, "0.00")
'---Hashtable---
tt = Timer
For a = 1 To c
If Not HT.Contains(arr(a)) Then HT.Add arr(a), Empty
Next
tt = Timer - tt: Debug.Print "Array * " & c & " Hashtable Time: " & Format(tt, "0.00")
'---ArrayList---
tt = Timer
For a = 1 To c
If Not AL.Contains(arr(a)) Then AL.Add arr(a)
Next
tt = Timer - tt: Debug.Print "Array * " & c & " ArrayList Time: " & Format(tt, "0.00")
'---Dictionary---
tt = Timer
For a = 1 To c
If Not DC.Exists(arr(a)) Then DC.Add arr(a), Empty
Next
tt = Timer - tt: Debug.Print "Array * " & c & " Dictionary Time: " & Format(tt, "0.00")
'---Collection---
tt = Timer
For a = 1 To c
On Error Resume Next
COL.Add arr(a), CStr(arr(a))
On Error GoTo 0
Next
tt = Timer - tt: Debug.Print "Array * " & c & " Collection Time: " & Format(tt, "0.00")
Set DC = Nothing: Set AL = Nothing: Set HT = Nothing: Set COL = Nothing
Next
End Sub
'----генератор стрингов----
Function TextGen(tt, ByVal ss%, ByVal LL%)
Dim aa As Byte, x%, t$, arr() As Byte, a As Byte, c%
ReDim arr(1 To 4, 1 To 2)
arr(1, 1) = 65: arr(1, 2) = 25: arr(2, 1) = 97: arr(2, 2) = 25
arr(3, 1) = 192: arr(3, 2) = 31: arr(4, 1) = 224: arr(4, 2) = 31
t = ""
If LL - ss > 0 Then c = ss + (Rnd * (LL - ss)) Else c = LL
For x = 1 To c
a = Rnd * 4
If a = 0 Then a = 1
aa = arr(a, 1) + (Rnd * arr(a, 2))
t = t & Chr(aa)
Next
tt = t
End Function
Добытчик уников на массивах:
Скрытый текст
Код
Sub UniList(arr(), dd, Optional S As Boolean = True)
Dim a&, b&, c&
If UBound(arr) + 1 - LBound(arr) + 1 > 1 Then
If S Then QuickSort arr(), LBound(arr), UBound(arr)
c = LBound(arr): b = 1
For a = LBound(arr) + 1 To UBound(arr)
If arr(a) > arr(c) Then b = b + 1: c = a
Next
If arr(a - 1) > arr(c) Then b = b + 1
Else: ReDim dd(1 To 1): dd(1) = arr(LBound(arr)): Exit Sub
End If
ReDim dd(1 To b): b = 1: c = LBound(arr): dd(b) = arr(c)
For a = LBound(arr) + 1 To UBound(arr)
If arr(a) > arr(c) Then b = b + 1: c = a: dd(b) = arr(c)
Next
If arr(a - 1) > arr(c) Then b = b + 1: dd(b) = arr(a - 1)
End Sub
'------QSort--------
Sub QuickSort(a(), ByVal L&, ByVal U&)
Dim I&, J&, y, x
I = L: J = U: x = a((L + U) \ 2)
Do
Do While a(I) < x: I = I + 1: Loop
Do While x < a(J): J = J - 1: Loop 'a->c
If I <= J Then
y = a(I): a(I) = a(J): a(J) = y: I = I + 1: J = J - 1
End If
Loop Until I > J
If L < J Then QuickSort a(), L, J
If I < U Then QuickSort a(), I, U
End Sub
Anchoret, большое спасибо! Заинтересован))) и сортер годный. Пара вопросов: 1. передаём в UniList 2 массива ("принудительный" Variant() и вариативный Variant) - почему так? Мы же просто должны одномерный массив передать и получить на выходе уникальный (изменённый входящий) - не? 2. почему у сортера также аж 3 аргумента, причём последние 2 - границы массива (первого аргумента). Неужели он сам их определить не может?…
Изменено: - 04.03.2019 11:30:45
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
04.03.2019 12:27:39
Jack Famous, кто-то так и не освоился с массивами + параметрами процедур?) Квик не самой быстрой реализации. Но вроде работает корректно. Где-то здесь на форуме его встретил. Немного ускорил за счет Do While..Loop вместо While ...Wend
'===========================================================================================
'Переделано в функцию на основе данной процедуры: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=8&TID=6998&TITLE_SEO=6998&MID=281882#message281882
'===========================================================================================
Public Function PRDX_ArraySort(arr()) As Variant()
Dim v, u&, d&, f&, temp
temp = arr: f = LBound(temp): d = f
For u = f + 1 To UBound(temp)
If temp(u) < temp(d) Then
v = temp(d): temp(d) = temp(u): temp(u) = v
u = d - 1: d = u - 1: If u < f Then d = u: u = f
End If
d = d + 1
Next u
PRDX_ArraySort = temp
End Function
Изменено: - 04.03.2019 12:49:24
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
04.03.2019 12:48:12
Цитата
Jack Famous написал: Мы же просто должны одномерный массив передать и получить на выходе уникальный (изменённый входящий) - не?
Можно и так, но входной массив с данными может быть полезен для других де. И поскольку он передается по ссылке, то поганить его содержимое не решился.
Цитата
Jack Famous написал: почему у сортера также аж 3 аргумента, причём последние 2 - границы массива (первого аргумента)
QuickSort - рекурсивная процедура вызывающая сама себя.
Option Explicit
Private Sub zxzxzx()
Dim a&, b&, c&, d&, x, temp, arr(), dd, t!, dic As Object, COL As New Collection
Set dic = CreateObject("Scripting.Dictionary"): d = 500000: Randomize
For c = 10000 To d Step d / 10
ReDim arr(1 To c)
For a = 1 To c
b = Rnd * c: arr(a) = b
TextGen arr(a), 10, 10: b = Rnd * c: arr(a) = b
Next a
'---UniList---
t = Timer
UniList arr(), dd
Debug.Print "Array * " & c & " UniList Time: " & Format$(Timer - t, "0.00 sec")
'---Dictionary---
t = Timer
For Each x In arr
temp = dic.Item(x)
Next x
Debug.Print "Array * " & c & " Dictionary Time: " & Format$(Timer - t, "0.00 sec")
'---Collection---
t = Timer: On Error Resume Next
For Each x In arr
COL.Add x, CStr(x)
Next x
On Error GoTo 0: Debug.Print "Array * " & c & " Collection Time: " & Format$(Timer - t, "0.00 sec")
dic.RemoveAll: Set COL = Nothing
Next c
End Sub
'----генератор стрингов----
Private Function TextGen(tt, ByVal ss%, ByVal LL%)
Dim aa As Byte, x%, t$, arr() As Byte, a As Byte, c%
ReDim arr(1 To 4, 1 To 2)
arr(1, 1) = 65: arr(1, 2) = 25: arr(2, 1) = 97: arr(2, 2) = 25
arr(3, 1) = 192: arr(3, 2) = 31: arr(4, 1) = 224: arr(4, 2) = 31
t = ""
If LL - ss > 0 Then c = ss + (Rnd * (LL - ss)) Else c = LL
For x = 1 To c
a = Rnd * 4
If a = 0 Then a = 1
aa = arr(a, 1) + (Rnd * arr(a, 2))
t = t & Chr(aa)
Next
tt = t
End Function
Private Sub UniList(arr(), dd, Optional S As Boolean = True)
Dim a&, b&, c&
If UBound(arr) + 1 - LBound(arr) + 1 > 1 Then
If S Then QuickSort arr(), LBound(arr), UBound(arr)
c = LBound(arr): b = 1
For a = LBound(arr) + 1 To UBound(arr)
If arr(a) > arr(c) Then b = b + 1: c = a
Next
If arr(a - 1) > arr(c) Then b = b + 1
Else: ReDim dd(1 To 1): dd(1) = arr(LBound(arr)): Exit Sub
End If
ReDim dd(1 To b): b = 1: c = LBound(arr): dd(b) = arr(c)
For a = LBound(arr) + 1 To UBound(arr)
If arr(a) > arr(c) Then b = b + 1: c = a: dd(b) = arr(c)
Next
If arr(a - 1) > arr(c) Then b = b + 1: dd(b) = arr(a - 1)
End Sub
'------QSort--------
Private Sub QuickSort(a(), ByVal L&, ByVal U&)
Dim I&, J&, y, x
I = L: J = U: x = a((L + U) \ 2)
Do
Do While a(I) < x: I = I + 1: Loop
Do While x < a(J): J = J - 1: Loop 'a->c
If I <= J Then
y = a(I): a(I) = a(J): a(J) = y: I = I + 1: J = J - 1
End If
Loop Until I > J
If L < J Then QuickSort a(), L, J
If I < U Then QuickSort a(), I, U
End Sub
Изменено: - 16.04.2019 18:51:09
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
1. Пытался адаптировать ваш текстовый сортер, чтобы сравнить с рекурсивным квиком (пустые и прочерки забивал строками, а не числами, как тут) — не получилось (не дождался и вырубил) 2. Нашёл сортировку и вариант от — не получилось (не дождался и вырубил) 3. Добавил в вашу сортировку вариант с текстовым сравнением (без учёта регистра). При таком сравнении время на этих данных увеличилось почти в 2 раза (8,1 против 4,2 сек). Разделение функции на 2 разные (чтобы вызывать соответствующую и при рекурсии лишний раз не проверять), выигрыша во времени не дало, поэтому оставил в одной функции. Пытался реализовать через StrComp, но он оказался дольше + в смешанных данных сортирует числа как текст (что неудивительно, ведь это функция сравнения СТРОК). Интересно, что UCase быстрее UCase$ (во всяком случае, на этих данных), хотя я активно использую Left$, Mid$ и Right$, и они при сравнении были быстрее, чем "без долларов" 4. Устав пытаться усовершенствовать ваш вариант квика, принялся за сам поиск уникальных. Не понял, зачем в вашем варианте несколько циклов, если всё просто - идём со второго и, если он не равен предыдущему, добавляем в массив уникальных… Пробовал цикл For Each, но он подвёл, т.к. нужно идти со второго и дополнительные проверки сожрали время. Если в мой поисковик уникальных передавать массив для наполнения (как у вас) то он немного быстрее (80 против 100 мс). Я считаю это лишним, поэтому преобразовываю входящий и проигрываю (150 против 100 мс). Разумеется, оба эти значения невероятно малы, а поэтому ваще пофиг))) 5. Сортировка на моих данных занимает 4 или 8 сек (если без учёта регистра). Предполагаю, что увеличить можно, через StrConv(,vbFromUnicode) + проверяя первые несколько символов для предварительного ветвления (как у вас в текстовом). Попробую что-то сообразить в этом плане. Если сможете что-то "допилить", то буду очень рад, т.к. текстовый получился очень шустрым (хоть и с ограничениями). 6. Получение уникальных словарём занимает всего 1 сек (на 1 млн!!!), что в 4 раза быстрее, т.к. не требует сортировки + данные остаются в исходном порядке (хорошо это или плохо).
Для себя решил следующее - при работе с большими данными, буду сортировать и загружать их в Public-массивы (хватило бы памяти ) при открытии файла. Далее, при работе с файлом, получить любую информацию из таких массивов можно будет мгновенно. Для стандартного же поиска уникальных в повседневных задачах словарь отлично подходит.
P.S.: указание массива в аргументе функции для сортировки через arr() вместо вариативного arr сокращает время сортировки в 2 раза (на этих данных - с 8 до 4 сек). Вот, что значит корректное обращение
Коды
Код
Option Explicit
'============================================================================================================
Sub Arr1xSortCompare()
Dim arr(), tmpArr(), t!, tm!
Application.ScreenUpdating = False: tm = Timer
t = Timer: arr = Array2xTo1x([_1mlnName].Value2): Debug.Print "Преобразование в одномерный массив: " & Format$(1000 * (Timer - t), "0 мс")
t = Timer: Call UniqByDic(arr): Debug.Print "Получаем уникальные: " & Format$(1000 * (Timer - t), "0 мс")
't = Timer: Call Array1xSort(arr, 0, UBound(arr), False): Debug.Print "Сортировка: " & Format$(1000 * (Timer - t), "0 мс")
't = Timer: Call UniList(arr, tmpArr): arr = tmpArr: Debug.Print "Получаем уникальные: " & Format$(1000 * (Timer - t), "0 мс")
't = Timer: Call UniqSimple(arr): Debug.Print "Получаем уникальные: " & Format$(1000 * (Timer - t), "0 мс")
t = Timer: shZero.Cells.Delete: shZero.Cells(1, 1).Resize(UBound(arr) + 1, 1).Value2 = Array1xTranspose(arr): Debug.Print "Очистка листа и вывод на него с транспонированием: " & Format$(1000 * (Timer - t), "0 мс")
fin: Application.ScreenUpdating = True: Debug.Print "Итого: " & Format$(UBound(arr) + 1, "# ### ##0") & " штук за " & Format$(1000 * (Timer - tm), "0 мс")
End Sub
'============================================================================================================
Function Array1xSort(arr1x(), l&, u&, NoCase As Boolean)
Dim i&, j&, y, x
i = l: j = u
If NoCase Then
x = UCase$(arr1x((l + u) \ 2))
Do
Do While UCase$(arr1x(i)) < x: i = i + 1: Loop
Do While x < UCase$(arr1x(j)): j = j - 1: Loop 'a->c
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
Else
x = arr1x((l + u) \ 2)
Do
Do While arr1x(i) < x: i = i + 1: Loop
Do While x < arr1x(j): j = j - 1: Loop 'a->c
If i <= j Then y = arr1x(i): arr1x(i) = arr1x(j): arr1x(j) = y: i = i + 1: j = j - 1
Loop Until i > j
End If
If l < j Then Call Array1xSort(arr1x, l, j, NoCase)
If i < u Then Call Array1xSort(arr1x, i, u, NoCase)
End Function
'============================================================================================================
'============================================================================================================
Function UniList(arr1x(), dd)
Dim a&, b&, c&
c = LBound(arr1x): b = 1
For a = LBound(arr1x) + 1 To UBound(arr1x)
If arr1x(a) > arr1x(c) Then b = b + 1: c = a
Next
If arr1x(a - 1) > arr1x(c) Then b = b + 1
ReDim dd(1 To b): b = 1: c = LBound(arr1x): dd(b) = arr1x(c)
For a = LBound(arr1x) + 1 To UBound(arr1x)
If arr1x(a) > arr1x(c) Then b = b + 1: c = a: dd(b) = arr1x(c)
Next
If arr1x(a - 1) > arr1x(c) Then b = b + 1: dd(b) = arr1x(a - 1)
End Function
'------------------------------------------------------------------------------------------------------------
Function UniqSimple(arr1x())
Dim x, tmpArr(), i&, n&: ReDim tmpArr(0 To UBound(arr1x)): tmpArr(0) = arr1x(LBound(arr1x))
For i = LBound(arr1x) + 1 To UBound(arr1x)
If arr1x(i) <> arr1x(i - 1) Then n = n + 1: tmpArr(n) = arr1x(i)
Next i
ReDim Preserve tmpArr(0 To n): arr1x() = tmpArr()
End Function
'------------------------------------------------------------------------------------------------------------
Function UniqByDic(arr())
Dim x
With CreateObject("Scripting.Dictionary")
For Each x In arr: x = .Item(x): Next x
arr = .keys
End With
End Function
'============================================================================================================
'============================================================================================================
Function Array1xTranspose(arr1x()) As Variant()
Dim x, r&: ReDim arr2x(1 To UBound(arr1x) + 1, 1 To 1)
For Each x In arr1x
r = r + 1: arr2x(r, 1) = x
Next x
Array1xTranspose = arr2x
End Function
'============================================================================================================
Function Array2xTo1x(arr2x) As Variant()
Dim x, i&: ReDim arr1x(0 To UBound(arr2x, 1) * UBound(arr2x, 2) - 1): i = -1
For Each x In arr2x
i = i + 1: If Len(x) > 1 Then arr1x(i) = x Else arr1x(i) = i
Next x
ReDim Preserve arr1x(0 To i): Array2xTo1x = arr1x
End Function
Файл с миллионом элементов на листе на
Изменено: - 23.04.2019 17:26:35
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Пользователь
Сообщений: Регистрация: 01.01.1970
Anchoret
23.04.2019 18:06:32
Цитата
Jack Famous написал: 4. Устав пытаться усовершенствовать ваш вариант квика
Ну это не мой вариант, а стыренный где-то здесь на форуме) И вообще "лучшее враг хорошего" (с).
Цитата
Jack Famous написал: Если сможете что-то "допилить", то буду очень рад
Я вляпался в кап.ремонт и он сжирает всё время и все силы. Голова после точно не работает как надо. Может через месяц другой)
Видимо при попытке впихнуть Mid'ом в большую подстроку меньшую считываемая подстрока приравнивается к пустоте, или в случае сортера к набору пробелов.
Цитата
Jack Famous написал: Получение уникальных словарём занимает всего 1 сек (на 1 млн!!!)
И это странно, т.к. у меня уже после 100к скорость заполнения словаря резко падала, причем в разы. Но если есть способ заставить работать словарь шустрее, то всякие подобные варианты извлечения уников и не нужны.
или всё-таки "дорога возникает под ногами идущего"?
Цитата
Anchoret: у меня уже после 100к скорость заполнения словаря резко падала, причем в разы
всё верно, только не после 100к элементов исходного массива, а после 100к уникальных элементов. Вот я сейчас прогнал по целочисленному массиву, в котором из миллиона исходного массива 976к уникальных — словарь работал 40 секунд, а квик 2 (!!!) секунды. Походу стек переполняется или вроде того. Попробую прикрутить какие-нибудь понты к словарю
):
приветствую!
