Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Альтернатива стандартной VBA функции Replace
 
В общем альтернатива быстрее, или я что-то намудрил...
Функция:
Код
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

Тестер:
Скрытый текст
Время:
Скрытый текст
Изменено: Anchoret - 11.03.2019 04:50:37 (обновил тестовую процедуру)
Замена стандартной функции VBA Split на пользовательскую
 
Провёл маленький эксперимент, т.к. всегда расстраивало время работы стандартной функции на больших объёмах данных. Эксперимент оказался успешен.
Функция:
Код
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
Тестер:
Скрытый текст
Время:
Скрытый текст
Изменено: Anchoret - 11.03.2019 05:46:03 (подправил функцию)
Пользовательский аналог Dictionary
 
Решил поиграться с созданием класса... Вот, что из этого получилось.

А получился эквивалент объекта 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 опережает по скорости

- Минусы:
    -- жесткая привязка к отсорованности списка ключей
    -- медленная скорость на малых объемах (по сравнению со словарём)
    -- необходимость вставлять модуль класса в каждый проект, где этот объект может быть задействован
------------------------------------------- Updated 22.03.19 ---------------------------------------------
Добавлены методы:
    - Add Key, Value - добавление пары ключ/значение в объект
    - AddKey Key - Добавление ключа с пустым итемом
    - AddKeysFromArray Arr(), n,  s - Добавление ключей списком , список ключей в виде одномерного/двумерного массива, в случае двумерного массива  номер "столбца", нужно ли сортировать список перед выборкой из него списка уникальных и внесения в объект
    - AddKeysFromList Arr(),  IsUnic - тоже самое, что и пункт выше - массив/список, все ли значения в списке уникальны
    - RemoveByKey Key - удаление пары ключ/значение по ключу
    - RemoveByKeysList KeysList() - удаление по списку ключей в виде одномерного массива
    - RemoveByID Idx - удаление пары ключ/значение по номеру индекса
    Для внешних по отношению к объекту/классу массивов:
    - txtSort Arr(), nCol,  iComp - тестовый сортер с проверкой на пустые значения в опорном "столбце" массива. Все пустоты переносятся хвост отсортированного массива. Только по возрастанию. Двумерный массив, "столбец" массива, установка режима сравнения строк - 0 - Binary, 1 - Text
    - GetUnicFromIdxList IdxArr(), Arr(), Xpos, needSort - получение из двумерного массива по списку индексов (строк)и по опорному "столбцу" списка уникальных значений отсортированных по возрастанию. Список индексов, просматриваемый массив, "столбец" массива, нужно ли сортировать добытый список перед выборкой уникальных. В массив со списком индексов вернется список уникальных значений. Последняя опция не просто выбор сортировать/не сортировать - от нее зависит корректность добычи уникальных значений, поэтому если просматриваемый массив с порядком индексов просмотра не был предварительно отсортирован по возрастанию, то этот параметр нужно установить в True.
Тест по скорости наполнения + индексации:
Скрытый текст
Тестер:
Скрытый текст

П.С.: Замечания/советы/конструктивная критика приветствуется.
П.П.С.: Про очередной "велосипед" в курсе :)
Изменено: Anchoret - 22.03.2019 06:03:55
Двоичный поиск VBA в отсортированном двумерном массиве с набором вспомогательных процедур
 
Возможно кому пригодится...
Понравилось время поиска - таймер так и остается нулевым даже на массиве в 1кк.
Параметры (arr(), ByVal n%, ff, ByVal ll&, ByVal hh&, Optional S As Boolean = True):
- исходный массив в котором ищем
- номер столбца (если уместна такая аналогия с листом Excel)
- искомое значение (тип Variant и по ссылке, поэтому нужно быть осторожным). по результатам поиска в него возвращается позиция элемента или -1, если элемент не был найден
- верхняя граница поиска
- нижняя граница поиска
- нужно ли массив предварительно сортировать (True - да, False - нет)

Поисковик:
Скрытый текст

Вспомогательные процедуры:
Скрытый текст

Тестер + функция для генерации строк:
Скрытый текст

Результаты теста по времени:
Скрытый текст
Получение списка уникальных значений из одномерного массива VBA
 
Собственно это очередной тест драйв по скорости...
-------------
Сравнивались (отбор уникальных среди целых чисел):
- собственная процедура
- ArrayList (самый тормозной)
- Dictionary
- Collection
- Hashtable (System.Collections.Hashtable)
сравнение не совсем корректное, т.е. процедура выдает сразу массив с уникальными значениями, а все объекты только наполнялись.
---------------
Результат теста (числа):
Скрытый текст

Строки (среди финалистов :) ):
Скрытый текст

Тестовый макрос:
Скрытый текст

Добытчик уников на массивах:
Скрытый текст
Изменено: Anchoret - 05.03.2019 12:23:30
Эксперименты с SortedList
 
Листая форум наткнулся (в 2016 году, если память не изменяет) на сообщение от Hugo в одной из тем на тему этого объекта. Заинтересовало. Решил провести ряд экспериментов.
Интересовала в первую очередь скорость обработки данных и доступный в VBA инструментарий по работе с SortedList.
----------------
Для тех, кто не в курсе SortedList представляет из себя словарь (ключ, значение) сортирующий сам себя по факту наполнения. В качестве значения может сдержать: строки, числа, массивы, объекты.
---------------
Разочарование №1 - не доступна в VBA выгрузка ключей/итемов в массив, только циклом. Хотя такие методы есть
Разочарование №2 - скорость наполнения (в данном случае и одновременной сортировки) сопоставимо с Dictionary. Но наивно было бы ожидать большую разницу в меньшую сторону.
--------------
Тест-драйв по скорости:
Скрытый текст

Тестер:
Скрытый текст

Результат:
Скрытый текст

На миллионе SortedList завис минут на 10.
-----
В общем для небольших массивов пойдет.
----------------------------------------------------------------
Список доступных методов в VBA:
    Add - добавление пары ключ/значение
    Item - чтение/запись значения по ключу, или перезапись значения ключа
    Count - чтение - кол-во пар в SortedList
    Capacity - чтение/установка количества элементов объекта
Примеры:
Скрытый текст
    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 с примером же его использования:
Скрытый текст
Изменено: Anchoret - 20.02.2019 17:44:04
Преобразование значений и частично форматов из диапазона в HTML код
 
Всем привет)

Вымучил небольшую функцию для преобразования:
- значений
- частично размера шрифта
- наклона и толщины шрифта
- названия шрифта
- цвета фона и шрифта
из непрерывного диапазона ячеек в текстовую строку в виде HTML кода для дальнейшей вставки HTMLbody письма Outlook. Или иными словами - функция для пост.обработки диапазона в HTML для вставки таблицы в тело письма.

Собственно функция:
Скрытый текст

Вспомогательные функции:
Скрытый текст

Во вложении файл с примером использования.
Изменено: Anchoret - 11.03.2019 10:30:19 (изменил функцию)
Пользовательская функция-аналог Hex (10-16) для больших чисел
 
Возможно будет кому полезна)

Конвертирует десятичные целые числа в шестнадцатиричные.
Работает разумеется дольше штатной.
Максимально способна обрабатывать 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
Изменено: Anchoret - 20.04.2018 09:23:22
Полезности: Функция подсчета и "картографирования" цифровых групп в текстовой строке
 
Данная функция ищет вхождения цифровых групп в тексте, и:
- по своему имени возвращает True/False (есть или нет цифры в строке)
- в массиве возвращает первое вхождение группы и кол-во цифр в ней. Сколько групп цифр в строке, столько и пар вхождение/длина в массиве.
- отдельно возвращается кол-во групп цифр
- также отдельно возвращается позиция в массиве наибольшей (по кол-ву цифр) группы. Т.е. на указатель в массиве индекс первой цифры в строке.

Код и пример применения:
Скрытый текст
RegExp, скорость обработки данных п сравнению с обычными методами. Или я что-то делаю не то)
 
Понадобилось давеча повыковыривать числа из цифро-буквенной каши (массив цифро-буквенных данных на 10-15 т.элементов). А точнее первый блок цифр присутствующий в строке. Вспомнил , что неоднократно расхваливали RegExp за удобство и прочее, решил воспользоваться опытом товарищей. Что сказать... Действительно удобно, только почему-то ни разу не быстро. Может я что-то делаю не так, как нужно?

Функция по извлечению посредством RegExp:
Скрытый текст
Ее аналоги на стрингах и массивах:
Скрытый текст
Тестовый стенд:
Скрытый текст
Результат на моем не самом современном железе:
Скрытый текст
Пользовательская функция по поиску в длинных строках, т.е. за гранью возможностей стандартных функций по работе с текстом.
 
Написал небольшую функцию по поиску подстроки в строке. Возможно кому пригодится.
Функция расчитана на работу с любыми строками в ASC II кодировке.

Алгоритм и как все это работает:
- за основу был опробованный ранее матричный вариант разбивки строки посимвольно на группы индексов
- вначале строка с подстрокой поиска превращаются в набор байтов
- берется первый и последний байт подстроки
- по ним осуществляется индексация всех вхождений подобных символов/кодов/байтов в строке
- пару вложенных циклов с замером расстояния между символами/кодами
- встречное сравнение всех промежуточных байтов
- инкреация счетчика и запись начальных индексов в выходной массив - индексы вхождений

На 100кк символьной строке поиск подстроки из трех символов на моей древней АМДэшке занял чуть более 14 сек (около 900 вхождений).
Скорость работы зависит от количества подстрок в основной строке.
Сравнения с учетом регистра.
В качестве UDFки на листе будет возвращать только количество вхождений подстроки.

Тестер:
Скрытый текст
Поисковик:
Скрытый текст
Изменено: Anchoret - 28.03.2018 07:04:46
Сортировка в двумерном массиве методом распределения VBA Excel, Выношу на суд форумной общественности совместный с AAF труд по написанию альтернативы всем известным методам сортировки в массивах.
 
Небольшое предисловие)
Скрытый текст
В основу алгоритма положен метод первичного распределения исходных данных по группам и по матрицам. Далее уже идет досортировка.
Алгоритм или как все это работает:
Скрытый текст
Плюсы и минусы:
Скрытый текст
Во вложенном файле несколько модулей:
Скрытый текст
Примеры вызова процедуры (вдруг кто не знает):
Скрытый текст

В коде есть комментарии. Модуль с набором процедур сортировщика можно экспортировать и вставить в Ваши проекты.
Тема, где все это рождалось: Сортировка в двумерном массиве VBA Excel
Изменено: Anchoret - 09.02.2018 00:00:09
Сортировка в двумерном массиве 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 столбцу
- проходим "пузырьком" по списку уникальных значений
- по полученному в пред.пункте списку выгружаем массив по индексам ранее записанным в словаре

П.С.: Конструктивная критика и методы оптимизации приветствуются :)
Изменено: oldy7 - 05.12.2017 19:53:39
программный запрет на изменения фона в ячейке
 
Доброго времени суток!  
 
Задача - Запретить юзверям обесцвечивать любой выделенный диапазон.  
 
Вот моя попытка:  
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  
 
Этот код не работает.    
 
Спасибо.
Страницы: 1
Наверх