Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Выбрать дату в календареВыбрать дату в календаре

Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 33 След.
Получение списка уникальных значений из одномерного массива VBA
 
Цитата
Jack Famous написал:
4. Устав пытаться усовершенствовать ваш вариант квика
Ну это не мой вариант, а стыренный где-то здесь на форуме) И вообще "лучшее враг хорошего" (с).
Цитата
Jack Famous написал:
Если сможете что-то "допилить", то буду очень рад
Я вляпался в кап.ремонт и он сжирает всё время и все силы. Голова после точно не работает как надо. Может через месяц другой)
Цитата
Jack Famous написал:
(хоть и с ограничениями)
Видимо при попытке впихнуть Mid'ом в большую подстроку меньшую считываемая подстрока приравнивается к пустоте, или в случае сортера к набору пробелов.
Цитата
Jack Famous написал:
Получение уникальных словарём занимает всего 1 сек (на 1 млн!!!)
И это странно, т.к. у меня уже после 100к скорость заполнения словаря резко падала, причем в разы. Но если есть способ заставить работать словарь шустрее, то всякие подобные варианты извлечения уников и не нужны.
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Цитата
Jack Famous написал:
что миллион сортируется 2,734 сек на новом сортере?
Для каждого компа будет разное время. Как и писал ранее - на Intel'ах быстрее почти в два раза.
Цитата
Jack Famous написал:
Какие ещё ограничения по числам, кроме "рамки" целочисленного диапазона?
Не целочисленного диапазона. Все, что после запятой просто убирается с округлением по всем правилам при неявной конвертации входного числа в тип Long. Кол-во знаков после запятой не имеет значения.
Цитата
Jack Famous написал:
Не могли бы вы сделать частный случай сортировки для целых положительных чисел до 1 млн (1 — 1 000 000)?
Это Вы и сами сможете сделать (12-ю строку, 30-32 строки уберите из кода, ну и до кучи переменные m и p уже станут не нужны) :) Но для начала почитайте как компьютер видит числа. Точнее в каком виде они хранятся и прочее.

И для равномерно распределенных целых чисел лучше подойдет такой сортировщик.
Изменено: Anchoret - 28 Мар 2019 09:28:03
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Ещё дин числовой сортер на ограниченный диапазон чисел, но быстрее:
Код
Type mLng: l As Long: End Type
Type blArr: b(3) As Byte: End Type
'--------------------------------------
Sub NumSortL(arr(), ByVal n&)
Dim bMap(), bb() As blArr, d As mLng, m&, p&
Dim a&, b&, c&, dd&(), aa&(), x&, xx&
'------------------------------------------------------
ReDim bb(1 To (UBound(arr) - LBound(arr) + 1)): ReDim dd(LBound(arr) To UBound(arr))
x = LBound(arr) And 1 Xor 1
For a = LBound(arr) To UBound(arr)
  d.l = arr(a, n): LSet bb(a + x) = d: dd(a) = a
  If bb(a + x).b(3) And 128 Then m = m + 1 Else p = p + 1
Next
For a = 1 To 3: ReDim bMap(0 To 255): c = 0
  For b = LBound(dd) To UBound(dd)
    bMap(bb(dd(b)).b(a)) = bMap(bb(dd(b)).b(a)) + 1
  Next
  For b = LBound(dd) To UBound(dd)
    If IsArray(bMap(bb(dd(b)).b(a))) Then
      bMap(bb(dd(b)).b(a))(0) = bMap(bb(dd(b)).b(a))(0) + 1: bMap(bb(dd(b)).b(a))(bMap(bb(dd(b)).b(a))(0)) = dd(b)
    Else: ReDim aa(0 To bMap(bb(dd(b)).b(a))): aa(0) = 1: aa(1) = dd(b): bMap(bb(dd(b)).b(a)) = aa
    End If
  Next: xx = LBound(dd)
  For b = 0 To 255
    If IsArray(bMap(b)) Then
      For c = 1 To bMap(b)(0): dd(xx) = bMap(b)(c): xx = xx + 1: Next
    End If
  Next
Next: Erase bMap: aa = dd: p = m + 1: m = 1
For a = LBound(dd) To UBound(dd)
  If bb(dd(a)).b(3) And 128 Then aa(m) = dd(a): m = m + 1 Else: aa(p) = dd(a): p = p + 1
Next
dd = aa
For a = 2 To UBound(aa): x = a
  Do While arr(dd(x - 1), n) > arr(aa(a), n)
    dd(x) = dd(x - 1): x = x - 1
    If x = 1 Then Exit Do
  Loop
  dd(x) = aa(a)
Next: x = LBound(arr, 2): xx = UBound(arr, 2): Erase aa
ReDim bMap(LBound(arr) To UBound(arr), x To xx)
If LBound(arr) = 0 Then c = 1 Else c = 0
For a = 1 To UBound(dd)
  For b = x To xx: bMap(a + c, b) = arr(dd(a), b): Next
Next
arr = bMap: Erase dd: Erase bMap
End Sub

Диапазон от -16777215 до 16777215. При распределении дробная часть срезается, за счёт этого:
- уменьшается объем памяти занимаемый байтовым массивом с 8 на 4 байта под каждый элемент
- кол-во итераций распределения уменьшается на одну

При доводке вставками сравниваются уже оригинальные числа из сортированного массива, поэтому с дробной частью все ОК)
Если разделить сортер на два  - для отрицательных и положительных чисел отдельно, то ещё выиграем в скорости.
------------------
На моём домашнем драндулете получились такие тайминги:
Код
NumSort sorting, time: 3,172 Arr.1000000/1
NumSortL sorting, time: 2,734 Arr.1000000/1
AL.Sort sorting, time: 3,939 Array: 1000000/1

Последний испытуемый  - QuickSort упрощенной реализации. Первый - предыдущая версия числового сортировщика на Double.
Изменено: Anchoret - 28 Мар 2019 08:37:07
Двоичный поиск VBA в отсортированном двумерном массиве с набором вспомогательных процедур
 
Jack Famous, там на самом деле довольно простенький алгоритм заложен:
- выбирается примерный центр массива, где проводится поиск
- если искомый элемент меньше элемента в выбранном участке массива, берем нижнюю (ту, что с меньше по нумерации индексов) часть массива и снова делим ее надвое
- если больше, то делим верхнюю
- ну и так далее, пока диапазон не сокращается до 10 индексов, и тут циклом проверяем

П.С.: Этот поисковик встроен в пользовательский вариант Dictionary, именно поэтому там сортируется все и вся.
Изменено: Anchoret - 26 Мар 2019 14:05:23
Двоичный поиск VBA в отсортированном двумерном массиве с набором вспомогательных процедур
 
Jack Famous, тут как в космосе - верх и низ относительные понятия) Если от начала нумерации, то низ. Если представить двумерный массив в виде таблицы, то верх.
Двоичный поиск VBA в отсортированном двумерном массиве с набором вспомогательных процедур
 
Jack Famous,
1. Да
2. Если и не с листа тоже, или просто L/Ubound(arr)
3. Если там прячется сортер чисел или текста в чистом виде, то да. Клевер все еще не готов. А времени исправить это все еще нет)
Программы для защиты VBA-проектов (макросов) от взлома.
 
Excel + VBA - эффективная связка, но полноценного приложения все-равно не получится. Я о том, что VBA - это скорее развлечение для народа, чем среда разработки. И огорчаться "дырявостью" защиты проектов не стоит)
------------------------------------------------------------
Karataev в виде двух чисел Long
Изменено: Anchoret - 26 Мар 2019 07:10:25
Программы для защиты VBA-проектов (макросов) от взлома.
 
Karataev, есть такая штука - хеширование. Придумать алгоритм создания массива из отдельных кодов символов обработанных XOR , из которых будут собираться имена пользователей. И алгоритм считывания данных из такого массива.
----------
Еще есть интересный оператор выхода из процедуры при неверном вводе/не соблюдении условия (например) - End. Он не возвращает в вызвавший макрос, а просто прекращает выполнения макроса.
Изменено: Anchoret - 25 Мар 2019 10:32:07
Программы для защиты VBA-проектов (макросов) от взлома.
 
Karataev, весь смысл взлома - использовать, то что взломано для своих целей. не понимая логику трудно что-то использовать правильно. К тому-же в коде могут быть использованы значения со скрытых листов и пр.. Часть этих значений может в свою очередь быть зависимой от результатов вычислений формул. А сами формулы также частично могут генериться программой (макросом). Как часть защиты - использовать привязку серийников оборудования (для проектов расчитанных на конкретного пользователя с конкретным же набором оборудования. Но есть сложность - код как правило пишется по удаленке, и все это оборудование неизвестно. Для корпоративных проектов - список имен пользователей допущенных к использованию файла с проектом.
Программы для защиты VBA-проектов (макросов) от взлома.
 
Karataev, я так понимаю, что Андрей говорил о воссоздании графической (формы) составляющей проекта на основе считанного кода)
И вообще копаться в чужом коде дело не благодарное. Одно дело поковырять макрос в пару десятков строк, и совершенно другое пытаться понять логику и пр. по проекту с десятком модулей, сотней процедур и функций. А если еще программист использует переменные названные не по всем правилам, то ой)
Объединение последовательных чисел в числовой период
 
UDF:
Код
Function NumbersPeriod(TXT, d As Long) As String
Dim a&, b&, c&, arr(), dd&(), t$, tt, x&
'------------------------------------------
tt = Split(Replace(Replace(TXT, " ", ""), Left(TXT, d), ""), ",") 'сжигаем пробелы, удаляем символьный префикс, разбиваем по зяпятым
ReDim arr(LBound(tt) To UBound(tt))
For a = LBound(tt) To UBound(tt): arr(a) = CLng(tt(a)): Next 'конвертим текст в числа
ReDim dd(LBound(arr) To UBound(arr)): dd(LBound(dd)) = arr(LBound(arr))
For a = LBound(arr) + 1 To UBound(arr): b = a 'сортируем числа
  Do While dd(b - 1) > arr(a)
    dd(b) = dd(b - 1): b = b - 1
    If b = LBound(arr) Then Exit Do
  Loop: dd(b) = arr(a)
Next: Erase arr
t = Left(TXT, d): b = 0
For a = LBound(dd) To UBound(dd) 'создаем массив с периодами
  c = dd(a): x = 0
  Do While dd(a) - c - x = 0
    a = a + 1: x = x + 1
    If a > UBound(dd) Then Exit Do
  Loop
  a = a - 1: b = b + 1: ReDim Preserve arr(1 To b)
  If x = 1 Then arr(b) = t & c Else arr(b) = t & c & "-" & t & dd(a)
Next
NumbersPeriod = Join(arr, ",") 'объединяем периоды из массива в строку
End Function
Как ускорить работу макроса заливки ячеек?
 
С таймером в [F2] и не только:
Код
Sub iCol()
Application.ScreenUpdating = False
Dim iRng As Range, aa As Range, iAddr$, a&, b&, Arr(), t#
Set aa = Range("C7:E" & Cells(Rows.Count, "C").End(xlUp).Row): t = Timer
If Len([E2]) > 0 Then
  Arr = aa.Value: aa.Font.Color = RGB(0, 0, 0)
  For a = 1 To UBound(Arr)
    For b = 1 To UBound(Arr, 2)
      If InStr(1, Arr(a, b), [E2], 1) Then
        If iRng Is Nothing Then Set iRng = aa(a, b) Else Set iRng = Union(iRng, aa(a, b))
      End If
    Next
    If a Mod 100 = 0 Then Application.StatusBar = "Процент выполнения задачи: " & Int(a / UBound(Arr) * 100) & "%"
  Next
  Application.StatusBar = "Процент выполнения задачи: " & Int(a / UBound(Arr) * 100) & "%"
  If Not iRng Is Nothing Then iRng.Font.Color = RGB(218, 16, 16)
Else: aa.Font.Color = RGB(0, 0, 0)
End If: [F2].NumberFormat = "@": [F2] = Format(Timer - t, "0.000")
Application.ScreenUpdating = True
End Sub

На самом деле обход только массива - сотые доли секунды, всё остальное работа с диапазоном. Поэтому решения у этой задачи скорее всего нет.
Изменено: Anchoret - 22 Мар 2019 21:05:49
Как ускорить работу макроса заливки ячеек?
 
Hashtag, попробуйте)
Как ускорить работу макроса заливки ячеек?
 
Hashtag, Формул, форматов, Уф много в открытых книгах? Если да, то стоит еще отключать/включать калькуляцию. А так ускорить можно, если написать алгоритм поиска отличный от тупого перебора элементов массива) Еще есть вариант при переборе массива в отдельный массив скидывать адреса ячеек с найденным вхождением, а потом разом слить этот массив в строку через запятую и скормить ее оператору Range.
-------------
Нет , так не выйдет. Видимо ограничение на количество операндов в Range.
Изменено: Anchoret - 22 Мар 2019 20:25:03
Как ускорить работу макроса заливки ячеек?
 
Точнее вот так.
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Jack Famous, все сортеры по отдельности работают нормально. во всяком случае те, что недавно добавлены. Двоичное древо в числовом сортере работает через раз, буду от него избавляться. Но времени пока не очень много.
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Jack Famous, Clever'а я туда не впихивал, если Вы об этом. Он слишком огромен и все еще косячит на миксах.
Как ускорить работу макроса заливки ячеек?
 
Hashtag, изменил код выше.
Как ускорить работу макроса заливки ячеек?
 
Код
Sub iCol()
Application.ScreenUpdating = False
Dim iRng As Range, aa As Range, iAddr$, a&, b&, c&, Arr()
Set aa = Range("C7:E" & ActiveSheet.UsedRange.Rows.Count)
If Len([E2]) > 0 Then
  Arr = aa.Value: aa.Font.Color = RGB(0, 0, 0)
  For a = 1 To UBound(Arr)
    For b = 1 To UBound(Arr, 2)
      If InStr(1, Arr(a, b), [E2], 1) Then
        If iRng Is Nothing Then Set iRng = aa(a, b) Else Set iRng = Union(iRng, aa(a, b))
      End If
    Next
  Next
  If Not iRng Is Nothing Then iRng.Font.Color = RGB(218, 16, 16)
Else: aa.Font.Color = RGB(0, 0, 0)
End If
Application.ScreenUpdating = True
End Sub

Не проверял.
Изменено: Anchoret - 22 Мар 2019 20:02:46
Пользовательский аналог Dictionary
 
Расширил список методов класса.
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
ALFA, с чего бы это:
Код
  'первичный индексный массив
  ReDim gg(LBound(mass, 1) To UBound(mass, 1))

---------------
В ходе очередного теста были выявлены ошибки, точнее их наличие, при сортировке миксованных по типам данных. немного подкорректированную версию выложил в #166. Но ошибки не все еще устранены...
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
ALFA, а лучше вот так, чтобы не пересчитывать все остальные переменные (это будущий массив индексов):
Код
ReDim T1A(1 To UBound(mass) - LBound(mass) + 1)
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Добавил таки новый сортировщик текста и чисел (частично, в основном на досортировке длинных хвостов). Провёл эксперимент с альтернативой сортировщика дат - эксперимент провалился (долго сортирует). Попутно исправил ошибку в сортировщике чисел (убрал Option Base, и в одном месте кода не была проставлена нижняя граница расширяемого массива) и дат (не правильно считались минимумы с максимумами).
Изменено: Anchoret - 20 Мар 2019 19:14:44
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Цитата
ALFA написал:
столбец по которому выполняется сортировка содержит текст, верно?
Да)
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
ALFA, изменил код текстового сортера в № 147.
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Jack Famous, и то и другое)
ALFA, бегло просмотрел код - да, можно убрать Option Base 1. И это не только моё решение, писалось в соавторстве с AAF :)
-------
Последние пару дней пытаюсь внедрить последние придумки по числовой и текстовой сортировке в CleverSort. Скоро выложу сюда обновлённый вариант.

П.С.: в Клевере обнаружен трудно отловимый баг - при сортировке текста значения в массиве иногда дублируются... А так там хренова куча кода, то разобраться не просто. Если нужен текстовый сортер, то лучше использовать одно из последних решений от AAF или моё (нужно проверить как он будет сортировать массив с нижней границей в 0, есть вероятность что не очень корректно...).
Открыть книгу макросом на нужном листе, заданном в другой книге, Работа с двумя файлами
 
Код
Dim wb as WorkBook,  t$
t = Sheets ("Ввод").[A1]
Set wb=WorkBooks.Open("C:\Users\name\Documents\Пример.xlsx")
Sheets (t).Activate
Изменено: Anchoret - 18 Мар 2019 23:47:40
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Jack Famous, там не считаются знаки ни после запятой ни до нее) Просто раскладывается число Double на 8 байт, потом с 4 по 7 байты идет цикличное распределение по матрице 0-255, слив всех индексов с матрицы в единый массив, и заново. Затем проверяется старший бит старшего же байта (если он включен, то число отрицательное, если нет, то положительное). Ну а в конце - досортировка вставками по полученному индексному массиву. При этом при всем нет взаимосмещений индексов по равным элементам. Т.е. для двумерного массива такая сортировка корректна, в отличии от QuickSort и прочих шейкеров.

В сортировке текста также идет превращение строки в массив байтов, но только не всей, а первых трёх символов (выяснено опытным путём, что большего и не нужно). Проход от 3-го байта к первому, сборка индексного массива, вставки, сборка итогового массива по индексному. Всё.
------------
Обновил числовой сортер.
Изменено: Anchoret - 19 Мар 2019 02:49:44
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Jack Famous, если переделать отдельно для Integer, то будет почти в два раза быстрее. Байтовые числа соответственно еще быстрее после переделки  - всего один проход по распределению, даже досортировка не нужна будет. Вообще надо будет потестить вариант без досортинга,вдруг он и не нужен...
Досортинг нужен... 1 смещение при 10к, 243 при 100к. Визуализатор
Изменено: Anchoret - 18 Мар 2019 19:38:34
Сортировка в двумерном массиве VBA Excel, Написал тут небольшую процедурку, может кому будет полезна
 
Ещё один, только по числам (отрицательные/положительные) по аналогичному принципу.
- "Ахилесова пята" - не учитывает изначальную сортированность массива, т.е. будет сортировать что отсортированный, что не отсортированный массив одно время
- разброс числовых значений не имеет значения
Код
Type mDbl: d As Double: End Type
Type bArr: b(7) As Byte: End Type
'------------------------------------------------------
Sub NumSort(arr(), ByVal n&)
Dim bMap(), BB() As bArr, d As mDbl, m&, p&
Dim a&, b&, c&, dd&(), aa&(), x&, xx&
'------------------------------------------------------
ReDim BB(1 To (UBound(arr) - LBound(arr) + 1)): ReDim dd(LBound(arr) To UBound(arr))
x = LBound(arr) And 1 Xor 1
For a = LBound(arr) To UBound(arr)
  d.d = arr(a, n): LSet BB(a + x) = d: dd(a) = a
  If BB(a + x).b(7) And 128 Then m = m + 1 Else p = p + 1
Next
For a = 4 To 7: ReDim bMap(0 To 255): c = 0
  For b = LBound(dd) To UBound(dd)
    bMap(BB(dd(b)).b(a)) = bMap(BB(dd(b)).b(a)) + 1
  Next
  For b = LBound(dd) To UBound(dd)
    If IsArray(bMap(BB(dd(b)).b(a))) Then
      bMap(BB(dd(b)).b(a))(0) = bMap(BB(dd(b)).b(a))(0) + 1: bMap(BB(dd(b)).b(a))(bMap(BB(dd(b)).b(a))(0)) = dd(b)
    Else: ReDim aa(0 To bMap(BB(dd(b)).b(a))): aa(0) = 1: aa(1) = dd(b): bMap(BB(dd(b)).b(a)) = aa
    End If
  Next: xx = LBound(dd)
  For b = 0 To 255
    If IsArray(bMap(b)) Then
      For c = 1 To bMap(b)(0): dd(xx) = bMap(b)(c): xx = xx + 1: Next
    End If
  Next
Next: Erase bMap: aa = dd: p = m + 1
For a = LBound(dd) To UBound(dd)
  If BB(dd(a)).b(7) And 128 Then aa(m) = dd(a): m = m - 1 Else: aa(p) = dd(a): p = p + 1
Next: dd = aa
For a = 2 To UBound(aa): x = a
  Do While arr(dd(x - 1), n) > arr(aa(a), n)
    dd(x) = dd(x - 1): x = x - 1
    If x = 1 Then Exit Do
  Loop
  dd(x) = aa(a)
Next: x = LBound(arr, 2): xx = UBound(arr, 2): Erase aa
ReDim bMap(LBound(arr) To UBound(arr), x To xx)
If LBound(arr) = 0 Then c = 1 Else c = 0
For a = 1 To UBound(dd)
  For b = x To xx: bMap(a + c, b) = arr(dd(a), b): Next
Next
arr = bMap: Erase dd: Erase bMap
End Sub

Без проверки на пустоты. Скоростью особо не блещет - примерно равное время с индексным QuickSort.
В приложенном файле в единственном модуле комплексный тестер.
Изменено: Anchoret - 19 Мар 2019 19:24:45
Страницы: 1 2 3 4 5 6 7 8 9 10 11 ... 33 След.
Наверх