В общем альтернатива быстрее, или я что-то намудрил... Функция:
Код
Function aReplace(txt, findSStr$, replSStr$, Optional iComp& = 0) As String
Dim a&, b&, c&, arr$(), x&, f&, r&: f = Len(findSStr): r = Len(replSStr)
If f = 0 Then Exit Function
b = 0: a = InStr(1, txt, findSStr, iComp): c = 1
Do While a: b = b + 1: z = a + f: a = InStr(z, txt, findSStr, iComp): Loop: x = b
If b = 0 Then Exit Function
If z <= Len(txt) Then b = b + 1
aReplace = Space$(Len(txt) + (x * (r - f))): ReDim arr(1 To b)
b = 0: z = 1: a = InStr(1, txt, findSStr, iComp)
Do While a
b = b + 1: arr(b) = Mid$(txt, z, a - z): z = a + f: a = InStr(z, txt, findSStr, iComp)
Loop
If Len(txt) >= z Then b = b + 1: arr(b) = Mid$(txt, z)
For a = 1 To UBound(arr)
Mid$(aReplace, c, Len(arr(a))) = arr(b): c = c + Len(arr(a))
If Len(aReplace) >= c Then Mid$(aReplace, c, r) = replSStr: c = c + r
Next
txt = b 'счётчик замен, только для теста функции
End Function
Тестер:
Скрытый текст
Код
Sub bbb()
Dim dt$, a&, b&, mm, tt#, x&, del$, ff, arr()
'------------------------
x = 1000000: del = " ": Randomize
For b = 100000 To x Step 100000
tt = Timer
ReDim arr(1 To b)
For a = 1 To b
TextGen arr(a), 5, 10
Next
mm = Join(arr, del)
tt = Timer - tt: Debug.Print "String generation time: " & Format(tt, "0.000") & " Words: " & UBound(arr)
ff = mm
tt = Timer
dt = aReplace(mm, del, "")
tt = Timer - tt: Debug.Print "aReplace - time: " & Format(tt, "0.000") & " String len: " & Len(dt) & " Replaced: " & mm
tt = Timer
dt = Replace(ff, del, "")
tt = Timer - tt: Debug.Print "Replace - time: " & Format(tt, "0.000") & " String len: " & Len(dt)
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
If ll - ss > 0 Then c = ss + (Rnd * (ll - ss)) Else c = ll
t = Space(c)
For x = 1 To c
a = Rnd * 4
If a = 0 Then a = 1
aa = arr(a, 1) + (Rnd * arr(a, 2))
Mid$(t, x, 1) = Chr(aa)
Next
tt = t
End Function
Провёл маленький эксперимент, т.к. всегда расстраивало время работы стандартной функции на больших объёмах данных. Эксперимент оказался успешен. Функция:
Код
Function LSplit(dt$, del$, arr())
Dim a&, b&, z&
b = 0: z = 1: z = 1: a = InStr(dt, del)
Do While a: b = b + 1: z = a + Len(del): a = InStr(z, dt, del): Loop
If Len(dt) > z Then b = b + 1
ReDim arr(1 To b): b = 0: z = 1: a = InStr(dt, del)
Do While a
b = b + 1: arr(b) = Mid$(dt, z, a - z): z = a + Len(del): a = InStr(z, dt, del)
Loop
If Len(dt) > z Then b = b + 1: arr(b) = Mid$(dt, z)
End Function
Тестер:
Скрытый текст
Код
Sub aaa()
Dim dt$, a&, b&, arr(), mm, tt#, x&, z&, dd, del$
'------------------------
x = 1000000: del = " "
For b = 100000 To x Step 100000
tt = Timer
ReDim arr(1 To b)
For a = 1 To b
TextGen arr(a), 5, 10
Next
dt = Join(arr, del)
tt = Timer - tt: Debug.Print "String generation time: " & Format(tt, "0.000") & " Words: " & b
tt = Timer
LSplit dt, del, arr()
tt = Timer - tt: Debug.Print "Fill array time: " & Format(tt, "0.000") & " Words: " & b
tt = Timer
dd = Split(dt, " ")
tt = Timer - tt: Debug.Print "Split string time: " & Format(tt, "0.000") & " Words: " & b
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
If ll - ss > 0 Then c = ss + (Rnd * (ll - ss)) Else c = ll
t = Space(c)
For x = 1 To c
a = Rnd * 4
If a = 0 Then a = 1
aa = arr(a, 1) + (Rnd * arr(a, 2))
Mid$(t, x, 1) = Chr(aa)
Next
tt = t
End Function
Решил поиграться с созданием класса... Вот, что из этого получилось.
А получился эквивалент объекта Dictionary заточенный под работу с массивами. Свойства/методы:
- Count - только чтение - количество записей в классе - Keys - только чтение - получение всех ключей объекта в виде одномерного массива - Items - только чтение - получение одномерного массива с итемами. - Exists - только чтение - Проверка на наличие ключа в классе (.Exists (Key)) - KeyID - только чтение - извлечение ключа по индексу (.KeyID (KeyID)) - ItemID - чтение/запись - добыча значения по индексу (.ItemID (KeyID)) либо перезапись значения (.ItemID (KeyID)= Value) - Item - чтение/запись - добыча значения по ключу (.Item (Key)) либо перезапись значения (.Item (Key)= Value) - ItemsByKeys - только чтение - извление списка значений в виде одномерного массива по списку ключей, если ключ не найден то в списке будет Empty (.ItemsByKeys (KeysList())) - Clear - метод - Полная очистка объекта - AddFromArrayID - метод - массовая загрузка ключей из одно/двумерного массива в объект. В случае с двумерным массивом нужно указать столбец, из которого будут извлекаться ключи. (.AddFromArrayID (SourceArray(), Column, sortedArr, notEmpty, addArr)):
-- входной массив . Как писал выше одно/двумерный. -- в случае двумерного массива номер "столбца" этого массива для добычи ключей -- опционально - по дефолту стоит False - сортирован ли массив -- опционально - по умолчанию True - игнорировать значения с длиной в текстовом эквиваленте 0 -- опционально - по умолчанию True - добавить к существующим записям (если таковые имеются) или заменить старые на новые
Извлекаются ключи из массива, если нужно сортируются, отбираются уникальные значения, в качестве значения к каждому ключу в массиве итемов прилагается массив с индексами, где было найден такой ключ в исходном массиве. Исходный массив не изменяется. - Sort - метод - сортировка внешнего для класса двумерного массива по определенному "столбцу"
Важно - если загнать в объект не сортированный массив, т.е. умышленно поставив True в соответствующем параметре загрузки, то будет ОЙ - более половины функционала потеряется. Поиск ключей точно работать не будет.
Если сравнивать с Dictionary плюсы и минусы: - Плюсы:
-- единовременная загрузка данных без цикла со стороны пользователя -- полная индексация исходного массива по добытым ключам -- как и в Dictionary есть единовременная выгрузка ключей/итемов в массив -- выборочное извлечение значений по списку ключей -- отсортированный по возрастанию список ключей -- сравнительное увеличение скорости загрузки массивов более 120к ключей. До этого кол-ва строк/ключей Dictionary опережает по скорости
- Минусы:
-- жесткая привязка к отсорованности списка ключей -- медленная скорость на малых объемах (по сравнению со словарём) -- необходимость вставлять модуль класса в каждый проект, где этот объект может быть задействован
- AddKey, Value - добавление пары ключ/значение в объект - AddKeyKey - Добавление ключа с пустым итемом - AddKeysFromArrayArr(), n, s - Добавление ключей списком , список ключей в виде одномерного/двумерного массива, в случае двумерного массива номер "столбца", нужно ли сортировать список перед выборкой из него списка уникальных и внесения в объект - AddKeysFromListArr(), IsUnic - тоже самое, что и пункт выше - массив/список, все ли значения в списке уникальны - RemoveByKeyKey - удаление пары ключ/значение по ключу - RemoveByKeysListKeysList() - удаление по списку ключей в виде одномерного массива - RemoveByIDIdx - удаление пары ключ/значение по номеру индекса Для внешних по отношению к объекту/классу массивов: - txtSortArr(), nCol, iComp - тестовый сортер с проверкой на пустые значения в опорном "столбце" массива. Все пустоты переносятся хвост отсортированного массива. Только по возрастанию. Двумерный массив, "столбец" массива, установка режима сравнения строк - 0 - Binary, 1 - Text - GetUnicFromIdxListIdxArr(), Arr(), Xpos, needSort - получение из двумерного массива по списку индексов (строк)и по опорному "столбцу" списка уникальных значений отсортированных по возрастанию. Список индексов, просматриваемый массив, "столбец" массива, нужно ли сортировать добытый список перед выборкой уникальных. В массив со списком индексов вернется список уникальных значений. Последняя опция не просто выбор сортировать/не сортировать - от нее зависит корректность добычи уникальных значений, поэтому если просматриваемый массив с порядком индексов просмотра не был предварительно отсортирован по возрастанию, то этот параметр нужно установить в True.
Sub test()
Dim a&, b&, arr, AL As ArrList, x&, DC As Object, dd, mm
Randomize: x = 300000
For mm = 10000 To x Step 10000
Set AL = New ArrList
Set DC = CreateObject("Scripting.Dictionary")
tt = Timer
ReDim arr(1 To mm, 1 To 1)
For a = 1 To UBound(arr)
TextGen arr(a, 1), 5, 5 'arr(a, 1) = Int(Rnd * x)
Next
tt = Timer - tt: Debug.Print "Generation time: " & Format(tt, "0.000") & " Array: " & mm
tt = Timer
For a = 1 To UBound(arr)
If Not DC.Exists(arr(a, 1)) Then
DC.Add arr(a, 1), Array(a)
Else
dd = DC.Item(arr(a, 1)): ReDim Preserve dd(LBound(dd) To UBound(dd) + 1)
dd(UBound(dd)) = a: DC.Item(arr(a, 1)) = dd
End If
Next
tt = Timer - tt: Debug.Print "Dictionary Fill time: " & Format(tt, "0.000") & " Array: " & mm
tt = Timer
AL.AddFromArrayID arr, 1, False, True, True
tt = Timer - tt: Debug.Print "Fill ArrList time: " & Format(tt, "0.000") & " Array: " & mm
tt = Timer
AL.Sort arr, 1
tt = Timer - tt: Debug.Print "Sorting time: " & Format(tt, "0.000") & " Array: " & mm
DoEvents
Next
End Sub
П.С.: Замечания/советы/конструктивная критика приветствуется. П.П.С.: Про очередной "велосипед" в курсе
Возможно кому пригодится... Понравилось время поиска - таймер так и остается нулевым даже на массиве в 1кк. Параметры (arr(), ByVal n%, ff, ByVal ll&, ByVal hh&, Optional S As Boolean = True): - исходный массив в котором ищем - номер столбца (если уместна такая аналогия с листом Excel) - искомое значение (тип Variant и по ссылке, поэтому нужно быть осторожным). по результатам поиска в него возвращается позиция элемента или -1, если элемент не был найден - верхняя граница поиска - нижняя граница поиска - нужно ли массив предварительно сортировать (True - да, False - нет)
Поисковик:
Скрытый текст
Код
Sub BinarySearch(arr(), ByVal n%, ff, ByVal ll&, ByVal hh&, Optional S As Boolean = True)
Dim c&, f As Boolean
If S Then SArrS arr(), n
Do While hh - ll > 10
c = ll + ((hh - ll) / 2 - 1)
Select Case arr(c, n)
Case Is = ff: f = True: Exit Do
Case Is > ff: hh = c
Case Is < ff: ll = c
End Select
Loop
If Not f Then
For c = ll To hh
If arr(c, n) = ff Then f = True: Exit For
Next
End If
If Not f Then ff = -1: Exit Sub
If c = LBound(arr) Then ff = c: Exit Sub
Do While arr(c - 1, n) = ff
c = c - 1
If c = LBound(arr) Then Exit Do
Loop
ff = c
End Sub
Вспомогательные процедуры:
Скрытый текст
Код
Sub SArrS(arr(), ByVal n%) 'сортировка двумерного массива
Dim sp, IDx
PreSort arr(), n, IDx, sp 'первичная сепарация на пустые и не пустые значения
If Not IsArray(IDx) Then Exit Sub 'если только пустышки в столбце, то сортировать нечего
QuickSortId arr(), n, IDx, LBound(IDx), UBound(IDx) 'сортировка массива с возвратом массива индекосв ч.1
IdxNormalize arr(), n, IDx 'нормализация взаиморасположения строк массива у одинаковых элементов в столбце
MergeIdSp IDx, sp 'слияние массивов индексов с не пустыми и пустыми значениями
ReBuildArr arr(), IDx 'сборка массива
End Sub
'----------------------------------------
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
Sub QuickSortId(a(), ByVal n%, IDx, ByVal L&, ByVal U&) 'по индексам для двумерного массива
Dim I&, J&, y&, x
I = L: J = U: x = a(IDx((L + U) \ 2), n)
Do
Do While a(IDx(I), n) < x: I = I + 1: Loop
Do While x < a(IDx(J), n): J = J - 1: Loop
If I <= J Then
y = IDx(I): IDx(I) = IDx(J): IDx(J) = y: I = I + 1: J = J - 1
End If
Loop Until I > J
If L < J Then QuickSortId a(), n, IDx, L, J
If I < U Then QuickSortId a(), n, IDx, I, U
End Sub
Sub PreSort(arr(), ByVal n%, IDx, sp)
Dim a&, b&, c&
For a = LBound(arr) To UBound(arr)
If Len(arr(a, n)) > 0 Then b = b + 1 Else c = c + 1
Next
If b > 0 Then ReDim IDx(1 To b): b = 1
If c > 0 Then ReDim sp(1 To c): c = 1
For a = LBound(arr) To UBound(arr)
If Len(arr(a, n)) > 0 Then
IDx(b) = a: b = b + 1
Else: sp(c) = a: c = c + 1
End If
Next
End Sub
Sub IdxNormalize(arr(), ByVal n%, IDx)
Dim a&, b&
If UBound(IDx) + 1 - LBound(IDx) - 1 = 1 Then Exit Sub
For a = LBound(IDx) + 1 To UBound(IDx)
Do While arr(IDx(a), n) > arr(IDx(a - 1), n)
a = a + 1
If a > UBound(IDx) Then Exit Do
Loop
If a > UBound(IDx) Then Exit For
b = a - 1
Do While arr(IDx(b), n) = arr(IDx(a), n)
a = a + 1
If a = UBound(IDx) Then Exit Do
Loop
If arr(IDx(b), n) <> arr(IDx(a), n) Then a = a - 1
QuickSort IDx, b, a
a = a - 1
Next
End Sub
Sub MergeIdSp(IDx, sp)
Dim a&, b&, aa()
If Not IsArray(sp) Then Exit Sub
aa = IDx: a = UBound(aa) + 1: b = 1
ReDim Preserve aa(LBound(IDx) To UBound(IDx) + UBound(sp))
Do
aa(a) = sp(b): b = b + 1: a = a + 1
Loop Until a > UBound(aa)
IDx = aa
End Sub
Sub ReBuildArr(arr(), IDx)
Dim a&, b&, sArr(), x&: x = LBound(arr)
ReDim sArr(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
For a = LBound(IDx) To UBound(IDx)
For b = LBound(arr, 2) To UBound(arr, 2)
sArr(x, b) = arr(IDx(a), b)
Next
x = x + 1
Next
arr = sArr
End Sub
Тестер + функция для генерации строк:
Скрытый текст
Код
Sub aaa()
Dim arr(), ll&, hh&, ff, a&, tt#, mm, x&
Randomize: x = 1000000
'[A:A].Clear
tt = Timer
ReDim arr(1 To x, 1 To 1)
For a = 1 To UBound(arr)
TextGen arr(a, 1), 10, 10 'arr(a, 1) = Int(Rnd * 65535)
Next
tt = Timer - tt: Debug.Print "Generation time: " & Format(tt, "0.000") & " Array: " & x
tt = Timer
SArrS arr(), 1
tt = Timer - tt: Debug.Print "Sorting time: " & Format(tt, "0.000") & " Array: " & x
With [a1].Resize(x, 1)
'.Value = arr
End With
ll = LBound(arr): hh = UBound(arr)
For a = 1 To 10
tt = Timer
ff = arr(Int(1 + (Rnd * (x - 1))), 1): mm = ff
BinarySearch arr(), 1, ff, ll, hh, False
tt = Timer - tt: Debug.Print "Search time: " & Format(tt, "0.000") & " What: " & mm & " Position: " & ff
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
Собственно это очередной тест драйв по скорости... ------------- Сравнивались (отбор уникальных среди целых чисел): - собственная процедура - 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
Листая форум наткнулся (в 2016 году, если память не изменяет) на сообщение от Hugo в одной из тем на тему этого объекта. Заинтересовало. Решил провести ряд экспериментов. Интересовала в первую очередь скорость обработки данных и доступный в VBA инструментарий по работе с SortedList. ---------------- Для тех, кто не в курсе SortedList представляет из себя словарь (ключ, значение) сортирующий сам себя по факту наполнения. В качестве значения может сдержать: строки, числа, массивы, объекты. --------------- Разочарование №1 - не доступна в VBA выгрузка ключей/итемов в массив, только циклом. Хотя такие методы есть Разочарование №2 - скорость наполнения (в данном случае и одновременной сортировки) сопоставимо с Dictionary. Но наивно было бы ожидать большую разницу в меньшую сторону. -------------- Тест-драйв по скорости:
Скрытый текст
Тестер:
Скрытый текст
Код
Sub nnn()
Dim SL As Object, a&, b&, c&, arr(), nn&, tt#
For c = 10000 To 100000 Step 10000
Set SL = CreateObject("System.Collections.SortedList")
ReDim arr(1 To c, 1 To 2)
tt = Timer
For a = 1 To c
For b = 1 To 2
nn = Rnd * c: arr(a, b) = nn
Next
Next
tt = Timer - tt: Debug.Print "Generate (" & c & ") time: " & tt
tt = Timer
For a = 1 To c
If Not SL.Contains(arr(a, 1)) Then SL.Add arr(a, 1), arr(a, 2)
Next
tt = Timer - tt: Debug.Print "Fill SortedList (" & c & ") time: " & tt
tt = Timer
ReDim arr(1 To SL.Count, 1 To 2)
For a = 0 To SL.Count - 1
arr(a + 1, 1) = SL.GetKey(a): arr(a + 1, 2) = SL.Item(arr(a + 1, 1))
Next
tt = Timer - tt: Debug.Print "Get to Array (" & c & ") time: " & tt
Next
Set SL = Nothing
End Sub
Результат:
Скрытый текст
Код
Generate (10000) time: 0,00390625
Fill SortedList (10000) time: 0,16015625
Get to Array (10000) time: 0,109375
Generate (20000) time: 0,00390625
Fill SortedList (20000) time: 0,29296875
Get to Array (20000) time: 0,22265625
Generate (30000) time: 0,00390625
Fill SortedList (30000) time: 0,4765625
Get to Array (30000) time: 0,33203125
Generate (40000) time: 0,0078125
Fill SortedList (40000) time: 0,72265625
Get to Array (40000) time: 0,46484375
Generate (50000) time: 0,0078125
Fill SortedList (50000) time: 0,984375
Get to Array (50000) time: 0,5546875
Generate (60000) time: 0,0078125
Fill SortedList (60000) time: 1,3125
Get to Array (60000) time: 0,6953125
Generate (70000) time: 0,0078125
Fill SortedList (70000) time: 1,625
Get to Array (70000) time: 0,80859375
Generate (80000) time: 0,01171875
Fill SortedList (80000) time: 1,99609375
Get to Array (80000) time: 0,90234375
Generate (90000) time: 0,0234375
Fill SortedList (90000) time: 2,40234375
Get to Array (90000) time: 1,02734375
Generate (100000) time: 0,015625
Fill SortedList (100000) time: 2,81640625
Get to Array (100000) time: 1,11328125
На миллионе SortedList завис минут на 10. ----- В общем для небольших массивов пойдет. ---------------------------------------------------------------- Список доступных методов в VBA:
Add - добавление пары ключ/значение Item - чтение/запись значения по ключу, или перезапись значения ключа Count - чтение - кол-во пар в SortedList Capacity - чтение/установка количества элементов объекта
Примеры:
Скрытый текст
Код
SL.Add "aaa", [A1] 'в данном случае записывается не ссылка на ячейку в виде объекта, а только ее содержимое
SL.Add "bbb", CreateObject("Scripting.Dictionary")
SL.Add "ccc", Array(1, 2, 3)
SL.Item("ddd") = 123
SL.Item("ddd") = 456
b = SL.Item("ddd")
a = SL.Capacity
SL.Capacity = 10
Clear - очистка объекта Clone - создание копии объекта Contains (Key) - проверка наличия определенного ключа в SortedList ContainsKey (Key) - проверка наличия определенного ключа в SortedList, т.е. тоже самое что и предыдущее ContainsValue (Value) - проверка наличия определенного элемента в SortedList. Не ключа. Полезная штука Equals(Object) - сравнение на идентичность двух объектов (например двa SortedList) GetByIndex(id) - добыча значения по индексу GetKey(id) - взять ключ по его индексу IndexOfKey(Key) - получаем индекс по ключу IndexOfValue(Value) - индекс по значению Remove(Key) - удаление пары ключ/элемент по ключу TrimToSize - подгонка пар ключ/элемент под определенное кол-во. В теории полезно только если был установлен завышенный размер массива элементов SortedList
--------------------------------------------------------------- Пример сортера на основе SortedList с примером же его использования:
Скрытый текст
Код
Sub aaa()
Dim a&, b&, c&, arr(), nn&, tt#, x&
c = 10000: x = 10
ReDim arr(1 To c, 1 To x)
For a = 1 To c
For b = 1 To x
nn = Rnd * c: arr(a, b) = nn
Next
Next
SLSort 1, arr()
End Sub
'--------------------------------------------
Sub SLSort(ByVal n%, arr())
Dim dd&(), a&, b&, SL As Object, iArr(), sp&(), gg&(), c&, z&, x&
Set SL = CreateObject("System.Collections.SortedList")
b = 0: c = 0: x = LBound(arr)
For a = x To UBound(arr)
If Len(arr(a, n)) > 0 Then
b = b + 1: ReDim Preserve gg(1 To b): gg(b) = a
Else
c = c + 1: ReDim Preserve sp(1 To c): sp(c) = a
End If
Next
For a = 1 To b
If Not SL.Contains(arr(gg(a), n)) Then
ReDim dd(1 To 1): dd(1) = a: SL.Add arr(gg(a), n), dd
Else
dd = SL.Item(arr(gg(a), n)): ReDim Preserve dd(1 To UBound(dd) + 1)
dd(UBound(dd)) = a: SL.Item(arr(gg(a), n)) = dd
End If
Next
ReDim iArr(x To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
If b > 0 Then
For a = 0 To SL.Count - 1: dd = SL.GetByIndex(a)
For b = 1 To UBound(dd)
For z = LBound(arr, 2) To UBound(arr, 2)
iArr(x, z) = arr(dd(b), z)
Next: x = x + 1
Next
Next
End If
If c > 0 Then
For a = 1 To c
For z = LBound(arr, 2) To UBound(arr, 2)
iArr(x, z) = arr(sp(a), z)
Next: x = x + 1
Next
End If
Set SL = Nothing: arr = iArr: Erase iArr: Erase dd: Erase sp: Erase gg
End Sub
Вымучил небольшую функцию для преобразования: - значений - частично размера шрифта - наклона и толщины шрифта - названия шрифта - цвета фона и шрифта из непрерывного диапазона ячеек в текстовую строку в виде HTML кода для дальнейшей вставки HTMLbody письма Outlook. Или иными словами - функция для пост.обработки диапазона в HTML для вставки таблицы в тело письма.
Собственно функция:
Скрытый текст
Код
Function RangeToHTML(RR As Range) As String
Dim dt$, a&, b&, c&, aa(), t$, MM(), m&, tt$(), q&
Dim t0$, t1$, t2$, t3$, n&, ro%, co%, dd()
'---------------------------------
ReDim aa(1 To RR.Columns.Count)
ReDim MM(1 To RR.Rows.Count, 1 To RR.Columns.Count)
For a = 1 To RR.Rows.Count
For b = 1 To RR.Columns.Count
If RR(a, b).MergeCells And Len(MM(a, b)) = 0 Then
For ro = a To RR(a, b).MergeArea.Rows.Count + a - 1
For co = b To RR(a, b).MergeArea.Columns.Count + b - 1: MM(ro, co) = "*": Next
Next
MM(a, b) = RR(a, b).MergeArea.Rows.Count & ";" & RR(a, b).MergeArea.Columns.Count
End If
If RR(a, b).NumberFormat <> "General" Then
t2 = Format(RR(a, b), RR(a, b).NumberFormat)
Else: t2 = RR(a, b)
End If
If Len(t2) > aa(b) Then aa(b) = Len(t2)
Next
Next
dt = "<html xmlns:v=""urn:schemas-microsoft-com:vml"" xmlns:o=""urn:schemas-microsoft-com:office:office""": wtArr tt, q, dt
dt = "xmlns:x=""urn:schemas-microsoft-com:office:excel"" xmlns=""http://www.w3.org/TR/REC-html40"">": wtArr tt, q, dt
dt = "<head><meta http-equiv=Content-Type content=""text/html; charset=windows-1251"">": wtArr tt, q, dt
dt = "<meta name=ProgId content=Excel.Sheet>": wtArr tt, q, dt
dt = "<meta name=Generator content=""Microsoft Excel 15""></head>": wtArr tt, q, dt
dt = "<body><table style=""border-collapse: collapse; "">": wtArr tt, q, dt
For a = 1 To RR.Rows.Count
dt = "<tr height=""" & Int(RR(a, b).Height) & """>": wtArr tt, q, dt
For b = 1 To RR.Columns.Count
c = RR(a, b).Interior.Color: t = PreHEX(c): t2 = vbNullString
m = RR(a, b).HorizontalAlignment: t3 = t2: n = RR(a, b).Width
Select Case m 'выравнивание по горизонтали
Case Is = -4131: t1 = """left"""
Case Is = -4108: t1 = """center"""
Case Is = -4152: t1 = """right"""
Case Is = 1: t1 = """justify"""
End Select
If Len(RR(a, b)) = 0 Then t2 = "width=""" & Int(n + n * 0.05) & """ "
If InStr(MM(a, b), ";") Then 'проверка на совмещенность ячеек
ro = Split(MM(a, b), ";")(0): co = Split(MM(a, b), ";")(1)
t2 = t2 & " rowspan=""" & ro & """ colspan=""" & co & """;"
End If
If MM(a, b) <> "*" Then 'проверка на совмещенность ячеек
dd = Array("-left:", "-right:", "-top:", "-bottom:"): t3 = "margin: 0px 2px 0px 2px;" 'отступы
If RR(a, b).IndentLevel > 0 Then t3 = t3 & " text-indent:" & RR(a, b).IndentLevel * 8 & "px;"
For n = 1 To 4 'бордюры
m = RR(a, b).Borders.Item(n).Weight
If m = 2 Then m = 1
If m = -4138 Then m = 2
c = RR(a, b).Borders.Item(n).LineStyle
Select Case c
Case Is = -4115: t0 = "dashed"
Case Is = 5: t0 = "dashed"
Case Is = -4118: t0 = "dotted"
Case Is = 13: t0 = "outset"
Case Is = -4119: t0 = "double"
Case Is > 0: t0 = "solid"
End Select
If c <> -4142 Then
t3 = t3 & " border" & dd(n - 1) & m & "px " & t0
t3 = t3 & " " & PreHEX(RR(a, b).Borders.Item(n).Color) & ";"
End If
Next
If InStr(t3, "border") < 1 And InStr(t3, "indent") < 1 Then t3 = t3 & " text-indent:2px;"
dt = "<td " & t2 & " align= " & t1 & " bgcolor= " & Chr(34) & t & Chr(34) & _
" style=""" & t3 & """><font": wtArr tt, q, dt 'цвет фона + рамка
dt = " face= """ & RR(a, b).Font.Name & """": wtArr tt, q, dt 'установка шрифта
dt = " color= """ & PreHEX(RR(a, b).Font.Color) & """": wtArr tt, q, dt
dt = "style=""font-size:" & RR(a, b).Font.Size & "pt"";>": wtArr tt, q, dt 'цвет шрифта + размер шрифта
If RR(a, b).Font.Bold Then dt = " <b>": wtArr tt, q, dt 'толщина шрифта
If RR(a, b).Font.Italic Then dt = " <i>": wtArr tt, q, dt 'наклон шрифта
If RR(a, b).NumberFormat <> "General" Then
t2 = Format(RR(a, b), RR(a, b).NumberFormat)
Else: t2 = RR(a, b)
End If
If Len(t2) < aa(b) Then
dt = t2 & String(aa(b) - Len(t2), " "): wtArr tt, q, dt
Else: dt = t2: wtArr tt, q, dt
End If
If RR(a, b).Font.Italic Then dt = "</i>": wtArr tt, q, dt
If RR(a, b).Font.Bold Then dt = "</b>": wtArr tt, q, dt
dt = "</font></td>": wtArr tt, q, dt
End If
Next
dt = "</tr>": wtArr tt, q, dt
Next
dt = "</table></body></html>": wtArr tt, q, dt: RangeToHTML = Join(tt, ""): Erase tt
End Function
Private Sub wtArr(arr$(), x&, dt$)
x = x + 1: ReDim Preserve arr(1 To x): arr(x) = dt
End Sub
Вспомогательные функции:
Скрытый текст
Код
Function PreHEX$(ByVal nn#)
Dim t$
t = D2xz(nn, 16, 6)
If Len(t) = 6 Then t = Right$(t, 2) & Mid$(t, 3, 2) & Left$(t, 2) Else t = Right$(t, 6)
PreHEX = "#" & t
End Function
Function D2xz(ByVal d, N As Long, Optional ByVal c%) As String
'автор Игорь Гончаренко
Const ch$ = "0 1 2 3 4 5 6 7 8 9 A B C D E F G H I J K L M N O P Q R S T U V W X Y Z"
Dim r%, D2C
If d > 0 Then
r = Int(Round(Log(d) / Log(N), 7)): D2C = Split(ch)
Do
D2xz = D2xz & D2C(Int(d / N ^ r)): d = d - Int(d / N ^ r) * N ^ r: r = r - 1
Loop Until r = -1
Else: D2xz = "0"
End If
If c > 0 Then
If c > Len(D2xz) Then D2xz = String(c - Len(D2xz), "0") & D2xz
End If
End Function
Конвертирует десятичные целые числа в шестнадцатиричные. Работает разумеется дольше штатной. Максимально способна обрабатывать 6-ти байтовые числа, после (из-за ограничения в Excel на количество цифр в числе) начинает выдавать фигню.
П.С.: Было бы интересно глянуть на более продвинутые варианты сего действа
Код
Function DecHexConv$(ByVal Num)
Dim aa, b%, c%, nn, cc$(), d%
aa = Array("A", "B", "C", "D", "E", "F")
'-------------------------
On Error Resume Next
Num = Fix(CDec(Num))
If Err.Number <> 0 Then Err.Clear: DecHexConv = "#Err": Exit Function
ReDim cc(0 To 0): b = 0: nn = Num
Do While Num / 255 > 1
c = 1
Do While nn > 255
nn = Fix(nn / 256): c = c + 1
Loop
Num = Num - (nn * (256 ^ (c - 1))): d = c - 1
If (nn And 240) / 16 > 9 Then cc(b) = aa(((nn And 240) / 16) - 10) Else cc(b) = CStr((nn And 240) / 16)
If (nn And 15) > 9 Then cc(b) = cc(b) & aa((nn And 15) - 10) Else cc(b) = cc(b) & (nn And 15)
nn = Num: b = b + 1: ReDim Preserve cc(0 To b)
Loop
Do While d > 1
cc(b) = "00": d = d - 1: b = b + 1: ReDim Preserve cc(0 To b)
Loop
If (nn And 240) / 16 > 9 Then cc(b) = aa(((nn And 240) / 16) - 10) Else cc(b) = CStr((nn And 240) / 16)
If (nn And 15) > 9 Then cc(b) = cc(b) & aa((nn And 15) - 10) Else cc(b) = cc(b) & (nn And 15)
'---------------------------
DecHexConv = "#" & Join(cc, "")
End Function
Данная функция ищет вхождения цифровых групп в тексте, и: - по своему имени возвращает True/False (есть или нет цифры в строке) - в массиве возвращает первое вхождение группы и кол-во цифр в ней. Сколько групп цифр в строке, столько и пар вхождение/длина в массиве. - отдельно возвращается кол-во групп цифр - также отдельно возвращается позиция в массиве наибольшей (по кол-ву цифр) группы. Т.е. на указатель в массиве индекс первой цифры в строке.
Код и пример применения:
Скрытый текст
Код
Sub Test()
Dim dt$, arr&(), c%, d%
dt = "afgdhrt456464bnhfy6785ghyrtdbssss123ghy56748393dfgd"
NumCount dt, arr(), c, d
End Sub
'------------------
Function NumCount(txt$, arr&(), c%, d%) As Boolean
Dim sb$, a%, ff As Boolean, b&
ff = False: ReDim arr(1 To 2): c = 0: b = 0: d = 1
If txt = vbNullString Then NumCount = False: Exit Function
For a = 1 To Len(txt)
sb = Mid$(txt, a, 1)
If sb Like "#" Then
If ff = False Then arr(UBound(arr) - 1) = a: c = c + 1
ff = True
ElseIf ff = True Then
b = a - arr(UBound(arr) - 1): arr(UBound(arr)) = b: ff = False
If b > arr(d + 1) Then d = c * 2 - 1
ReDim Preserve arr(1 To UBound(arr) + 2)
End If
Next
If ff = True Then
b = a - arr(UBound(arr) - 1) + 1: arr(UBound(arr)) = b
If b > arr(d + 1) Then d = c * 2 - 1
End If
If c > 0 Then
If arr(UBound(arr)) = 0 Then ReDim Preserve arr(1 To UBound(arr) - 2)
NumCount = True
End If
End Function
Понадобилось давеча повыковыривать числа из цифро-буквенной каши (массив цифро-буквенных данных на 10-15 т.элементов). А точнее первый блок цифр присутствующий в строке. Вспомнил , что неоднократно расхваливали RegExp за удобство и прочее, решил воспользоваться опытом товарищей. Что сказать... Действительно удобно, только почему-то ни разу не быстро. Может я что-то делаю не так, как нужно?
Функция по извлечению посредством RegExp:
Скрытый текст
Код
Function NumExtr(txt$) As Boolean
Dim RG As Object, a%, FD As Object
If Len(txt) = 0 Then NumExtr = False: Exit Function
Set RG = CreateObject("VBScript.RegExp")
RG.Pattern = "\d+": RG.Global = True
If Not RG.test(txt) Then NumExtr = False: Exit Function
Set FD = RG.Execute(txt): NumExtr = True: txt = FD.Item(0)
End Function
Ее аналоги на стрингах и массивах:
Скрытый текст
Код
Function NumExtrA(txt$) As Boolean
Dim sb$, dt$, a%, ff As Boolean
dt = "": ff = False
If Len(txt) = 0 Then NumExtrA = False: Exit Function
For a = 1 To Len(txt)
sb = Mid$(txt, a, 1)
If sb Like "#" Then
dt = dt & sb: ff = True
ElseIf ff = True Then Exit For
End If
Next
If Len(dt) > 0 Then txt = dt: NumExtrA = True
End Function
Function NumExtrB(txt$) As Boolean
Dim aa() As Byte, bb() As Byte, a%, ff As Boolean, b%
If Len(txt) = 0 Then NumExtrB = False: Exit Function
aa = StrConv(txt, 128): ff = False: ReDim bb(1 To Len(txt)): b = 0
For a = 0 To UBound(aa)
If aa(a) < 58 Then
If aa(a) > 47 Then
b = b + 1: bb(b) = aa(a): ff = True
ElseIf ff = True Then Exit For
End If
ElseIf ff = True Then Exit For
End If
Next
If b > 0 Then ReDim Preserve bb(1 To b): txt = StrConv(bb, 64): NumExtrB = True
End Function
Тестовый стенд:
Скрытый текст
Код
Sub ghjhfhfhhfy()
Dim arr$(), dt$, a&, iTime#
ReDim arr(1 To 100000)
For a = 1 To UBound(arr)
arr(a) = "asd-1234556GHJYYTRR-1567575"
Next
iTime = Timer
For a = 1 To UBound(arr)
NumExtrA arr(a)
Next
iTime = Timer - iTime
Debug.Print "NumExtrA"; Tab; UBound(arr); Tab; Round(iTime, 3)
iTime = Timer
For a = 1 To UBound(arr)
NumExtrB arr(a)
Next
iTime = Timer - iTime
Debug.Print "NumExtrB"; Tab; UBound(arr); Tab; Round(iTime, 3)
iTime = Timer
For a = 1 To UBound(arr)
NumExtr arr(a)
Next
iTime = Timer - iTime
Debug.Print "NumExtr"; Tab; UBound(arr); Tab; Round(iTime, 3)
End Sub
Написал небольшую функцию по поиску подстроки в строке. Возможно кому пригодится. Функция расчитана на работу с любыми строками в ASC II кодировке.
Алгоритм и как все это работает: - за основу был опробованный ранее матричный вариант разбивки строки посимвольно на группы индексов - вначале строка с подстрокой поиска превращаются в набор байтов - берется первый и последний байт подстроки - по ним осуществляется индексация всех вхождений подобных символов/кодов/байтов в строке - пару вложенных циклов с замером расстояния между символами/кодами - встречное сравнение всех промежуточных байтов - инкреация счетчика и запись начальных индексов в выходной массив - индексы вхождений
На 100кк символьной строке поиск подстроки из трех символов на моей древней АМДэшке занял чуть более 14 сек (около 900 вхождений). Скорость работы зависит от количества подстрок в основной строке. Сравнения с учетом регистра. В качестве UDFки на листе будет возвращать только количество вхождений подстроки.
Тестер:
Скрытый текст
Код
Sub test()
Dim txt$, dt$, tt#, a&, arrP
TextGen txt, 100000000, 100000000
TextGen dt, 3, 3
tt = Timer
a = TxtFindCount(txt, dt, arrP)
tt = Timer - tt
End Sub
'генератор символов
Function TextGen(tt$, ByVal ss&, ByVal ll&)
Dim aa As Byte, x&, t$, arr() As Byte, a As Byte, c&, bb() As Byte
ReDim arr(1 To 2, 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
ReDim bb(1 To c)
For x = 1 To c
a = Rnd * 2
If a = 0 Then a = 1
aa = arr(a, 1) + (Rnd * arr(a, 2))
bb(x) = aa
Next
tt = StrConv(bb, 64)
End Function
Поисковик:
Скрытый текст
Код
Function TxtFindCount&(iStr$, ByVal txt$, Optional arrP)
Dim mtrx(), ll&, ch1 As Byte, ch2 As Byte, bb() As Byte, aa() As Byte, a&, b&, c&
Dim x&, arr&(), a1&, a2&, c1&, c2&, ff As Boolean
ll = Len(txt): aa = StrConv(txt, 128): bb = StrConv(iStr, 128)
ch1 = aa(0): ch2 = aa(UBound(aa)): x = 0: c = 2
ReDim mtrx(0 To 255)
For a = 0 To UBound(bb): mtrx(bb(a)) = mtrx(bb(a)) + 1: Next
For a = 0 To UBound(bb)
If ch1 = bb(a) Or ch2 = bb(a) Then
If Not IsArray(mtrx(bb(a))) Then
ReDim arr(1 To mtrx(bb(a)) + 1): arr(1) = 2: arr(2) = a: mtrx(bb(a)) = arr()
Else: mtrx(bb(a))(1) = mtrx(bb(a))(1) + 1: mtrx(bb(a))(mtrx(bb(a))(1)) = a
End If
End If
Next
If Not IsArray(mtrx(ch1)) Or Not IsArray(mtrx(ch2)) Then TxtFindCount = 0: Exit Function
If ll = 1 Then
TxtFindCount = mtrx(ch1)(1) - 1: ReDim arrP(1 To mtrx(ch1)(1) - 1)
For a = 2 To mtrx(ch1)(1): arrP(a - 1) = mtrx(ch1)(a) + 1: Next
Exit Function
End If
ReDim arrP(1 To 1)
For a = 2 To mtrx(ch1)(1)
For b = c To mtrx(ch2)(1)
If mtrx(ch2)(b) > mtrx(ch1)(a) Then
c = b
If mtrx(ch1)(a) + ll - 1 <> mtrx(ch2)(b) Then Exit For
a1 = mtrx(ch1)(a): a2 = mtrx(ch2)(b)
c1 = 0: c2 = UBound(aa): ff = True: c = b + 1
Do While a2 - a1 > 1
c1 = c1 + 1: c2 = c2 - 1: a1 = a1 + 1: a2 = a2 - 1
If aa(c1) = bb(a1) Then
If aa(c2) <> bb(a2) Then ff = False: Exit Do
ff = True
Else: ff = False: Exit Do
End If
Loop
If ff Then x = x + 1: ReDim Preserve arrP(1 To x): arrP(x) = mtrx(ch1)(a) + 1: Exit For
End If
Next
Next
If x = 0 Then Erase arrP
TxtFindCount = x
End Function
Сортировка в двумерном массиве методом распределения VBA Excel, Выношу на суд форумной общественности совместный с AAF труд по написанию альтернативы всем известным методам сортировки в массивах.
Так уж получилось, что мне редко когда нравятся утвержденные стандарты и общепринятые алгоритмы. Все началось со стандартного Excel сортера, а точнее с попытки найти ему альтернативу в рабочем файле весом порядка 20 мб, с парой десятков листов нашпигованных формулами, и примерно таким же количеством VBA модулей. Excel сортировщик - это мощный инструмент с множеством опций и пр., но у него есть один недостаток - привязка к листу. Т.е. если вдруг возникла необходимость промежуточной сортировки массива, то нужно либо в текущем файле создавать лист, выгружать данные, сортировать, загружать обратно в массив, удалять лист. Либо создавать новую книгу со всеми выше описанными манипуляциями. Не очень удобно... И понеслось: "пузырьки" во всех их ипостасях, "вставки" и пр.. У всех методов сортировки есть свои плюсы и минусы. Какие-то слишком долгие, другие (например QuickSort) не совсем подходят для двумерных массивов ввиду небрежного отношения к индексам. Вот и решил написать свой вариант. Сильно помог AAF со своим вариантом сортировщика.
В основу алгоритма положен метод первичного распределения исходных данных по группам и по матрицам. Далее уже идет досортировка. Алгоритм или как все это работает:
Скрытый текст
- анализируется содержимое опорного столбца (по которому идет сортировка) на типы данных в нем представленных: числа (отрицательные и положительные), даты, текст. - в зависимости от типа данных подключаются субсортеры заточенные на определенный вид данных - далее распределение по деревьям/матрицам и досортировка - на финише сборка и деиндексация массива с перезаписью основного (входного) массива.
Плюсы и минусы:
Скрытый текст
+ на данных с равномерным распределением по значению этот метод идеален, т.е. линейное время сортировки. Зачастую время оценки входных данных больше времени самой сортировки - на числовых данных с малым интервалом по значению образующих своеобразные кластеры - уже все не так радужно - большой объем кода, как говорится: "без стакана не разберешься". Со стаканом спрочем тоже...
Во вложенном файле несколько модулей:
Скрытый текст
- Arr_sorters_test - тестовый стенд для оценки и сравнения описываемого здесь метода с другими - Clever_AAF_ - первоначальная версия распределителя с сотрировщиком AAF - CleverSort_UPD_ - итоговая версия, где труженнику от AAF поручена досортировка текста - TXT_Sorters - пара альтернативных версий для сортировки текста.
где в одномерном arr() - номер сортируемого столбца, направление сортировки (False - по возрастанию, True - по убыванию). Столбцов может быть несколько, но по каждому нужно указывать направление сортировки. Т.е. мульти сортинг. qwerty - сортируемый массив.
В коде есть комментарии. Модуль с набором процедур сортировщика можно экспортировать и вставить в Ваши проекты. Тема, где все это рождалось: Сортировка в двумерном массиве VBA Excel
Для работы нужно: - в переменной n номер столбца массива - в mass() собственно сам массив для сортировки
Код
Option Base 1
Dim qqq, arr00()
Sub iSort(ByVal n As Byte, ByVal mass As Variant)
Set indcol = CreateObject("Scripting.Dictionary")
If n > UBound(mass, 2) Then n = UBound(mass, 2)
If n < 1 Then n = 1
For a = 1 To UBound(mass, 1)
If mass(a, n) = "" Then mass(a, n) = Chr(1) & Chr(1)
If Not indcol.exists(mass(a, n)) Then
ReDim arr(1 To UBound(mass, 1) + 2)
arr(1) = 1: arr(2) = 3: arr(arr(2)) = a: indcol.Add mass(a, n), arr
Else
arr = indcol.Item(mass(a, n)): arr(1) = arr(1) + 1: arr(2) = arr(2) + 1: arr(arr(2)) = a: indcol.Item(mass(a, n)) = arr
End If
Next a
If indcol.Count = 1 Then n = 0: Exit Sub
arr0 = indcol.keys(): x = 0: xx = 0: qqq = UBound(arr0)
start:
For b = 1 To UBound(arr0)
If arr0(b) < arr0(b - 1) Then aa = arr0(b - 1): arr0(b - 1) = arr0(b): arr0(b) = aa: x = x + 1
Next b
xx = xx + x
If x > 0 Then x = 0: GoTo start
If xx = 0 Then n = 0: Exit Sub
ReDim arr00(1 To UBound(mass, 1), 1 To UBound(mass, 2))
x = 1
For a = 0 To UBound(arr0)
arr = indcol.Item(arr0(a))
For b = 1 To arr(1)
For c = 1 To UBound(arr00, 2)
arr00(x, c) = mass(arr(2 + b), c)
Next c
x = x + 1
Next b
Next a
For a = 1 To UBound(arr00, 1)
If arr00(a, n) = Chr(1) & Chr(1) Then arr00(a, n) = ""
Next a
End Sub
На выходе: - если все прошло хорошо, то в arr00() будет отсортированный входной массив - если n=0 значит массив не требует сортировки (одна строка либо все и так по возрастанию значений выбранного столбца)
Логика: - проверяется значение n на тему выхода за рамки ширины массива - через словарь индексируется содержимое входного массива по выбранному в n столбцу - проходим "пузырьком" по списку уникальных значений - по полученному в пред.пункте списку выгружаем массив по индексам ранее записанным в словаре
П.С.: Конструктивная критика и методы оптимизации приветствуются
Задача - Запретить юзверям обесцвечивать любой выделенный диапазон.
Вот моя попытка: Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Selection.Interior.ColorIndex = 0 Then With Application .EnableEvents = False .Undo .EnableEvents = True End With End If End Sub