Приветствую! Увидел закрытую тему и решил сделать макрофункцию.
Работает с максимумом (по умолчанию) и минимумом (3ий необязательный параметр). Если в диапазоне нет чисел, позиция больше количества чисел или меньше 1 — вернёт #ЗНАЧ.
Option Base 1
Option Explicit
'Option Private Module
'==================================================================================================
Private Function PRDX_Rng_ToArr1D_Num(rng_In As Range, a1D_Dbl_Out() As Double) As Boolean
Dim arr, aOne(1, 1)
Dim a&, r&, c&, e&
ReDim a1D_Dbl_Out(rng_In.Cells.CountLarge)
For a = 1 To rng_In.Areas.Count
arr = rng_In.Areas(a).Value2
If Not IsArray(arr) Then aOne(1, 1) = arr: arr = aOne
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
If (VarType(arr(r, c)) = vbDouble) Then e = e + 1: a1D_Dbl_Out(e) = arr(r, c)
Next r
Next c
Next a
If (e = 0) Then Exit Function
ReDim Preserve a1D_Dbl_Out(e): PRDX_Rng_ToArr1D_Num = True
End Function
'==================================================================================================
Private Sub PRDX_SortRecur_a1D_Double(a1D() As Double, LBnd&, UBnd&)
Dim i&, j&, x#, y#
i = LBnd: j = UBnd: x = a1D((LBnd + UBnd) \ 2)
Do
While a1D(i) < x: i = i + 1: Wend
While x < a1D(j): j = j - 1: Wend
If i <= j Then y = a1D(i): a1D(i) = a1D(j): a1D(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If LBnd < j Then PRDX_SortRecur_a1D_Double a1D, LBnd, j
If i < UBnd Then PRDX_SortRecur_a1D_Double a1D, i, UBnd
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function PRDX_Extremum(rng As Range, nPos&, Optional Min As Boolean) As Double
Dim aEx#(), UBnd&
If (nPos < 1) Then GoTo er
If Not PRDX_Rng_ToArr1D_Num(rng, aEx) Then GoTo er
UBnd = UBound(aEx): If (nPos > UBnd) Then GoTo er
PRDX_SortRecur_a1D_Double aEx, 1, UBnd
If Min Then PRDX_Extremum = aEx(nPos): Exit Function
PRDX_Extremum = aEx(UBnd - nPos + 1): Exit Function
er: PRDX_Extremum = CVErr(xlErrNA): Exit Function
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
'==================================================================================================
Функция не максимально оптимальна — нет ветки для более быстрого (без сортировки) нахождения 1го экстремума (самое мин/макс). Для этого есть штатные функции.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! В одном из моих проектов возникла необходимость хранить в памяти несколько небольших одинаковых по полям табличек и очень часто получать из них информацию по индексам. То есть, вводные данные — 3 числа: номер таблицы, номер строки, номер столбца.
Решил проверить, что быстрее и делюсь с вами(Планета и Кибер).
Часть 1. 1D массив с 2D массивами или один 2D массив. Второй вариант в 2 раза быстрее.
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub Test_TypeOfSafe()
Dim a(), aa(), a2D_Full(), aKoef&()
Dim t!, r&, c&, n&, m&, p&
Const rA& = 3, cA& = 2, mult& = 10, nCyc& = 100000000 ' 100 mln
' Prepare ===========================================================
' Arr2D =========================================
ReDim a(rA, cA)
For c = 1 To UBound(a, 2)
For r = 1 To UBound(a, 1)
a(r, c) = 10 * r + c
Next r
Next c
' Arr1D with Arr2D ==============================
ReDim aa(mult)
For n = 1 To UBound(aa)
aa(n) = a
Next n
' Full Arr2D ====================================
ReDim aKoef(mult)
ReDim a2D_Full(mult * rA, cA)
For n = 1 To mult ' 1 2 3 4 5 6 7 8 9 10
aKoef(n) = rA * (n - 1) ' 0, 3, 6, 9, 12, 15, 18, 21, 24, 27
For c = 1 To UBound(a, 2)
For r = 1 To UBound(a, 1)
a2D_Full(aKoef(n) + r, c) = a(r, c)
Next r
Next c
Next n
' Speed Test ========================================================
' ArrArr ========================================
t = Timer
For n = 1 To nCyc
p = aa(mult)(rA, cA)
Next n
Debug.Print "ArrArr", Format$(Timer - t, "0.0"), p ' 3.4 | 32
' a2D_Full ======================================
t = Timer
For n = 1 To nCyc
p = a2D_Full(aKoef(mult) + rA, cA)
Next n
Debug.Print "a2D_Full", Format$(Timer - t, "0.0"), p ' 1.7 | 32
' Show Arrays =======================================================
'Worksheets.add
'Cells(1, 1).Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
'Cells(1, 2 + UBound(a, 2)).Resize(UBound(a2D_Full, 1), UBound(a2D_Full, 2)).Value2 = a2D_Full
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
'==================================================================================================
В дальнейшем планирую проверить скорость ENum и User Defined Type — для превращения безликих индексов в осмысленные параметры.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Собственно, вопрос задан. Я причин не вижу. Более того, только что промахнулся с кнопкой и нажал ОК (также называется) возле окошка "Переместить во входящие" вместо "Ответить". И сколько так писем потерялось у людей …
Это просто очень глупо — так делать компоновку формы диалога…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Наткнулся на интересную тему (что редкость) и решил разобрать у себя. Формула от ТС оказалась гораздо короче и немного быстрее (при переносе на VBA), чем алгоритм с сайта. Кросс-таблица из темы ТСа преобразована в плоскую для удобства расчёта и сравнения. Несоответствие результата алгоритма (сайт "Gis-Lab") с проверочным (там же) — в том, что радиус Земли принят не совсем корректный (6 372 795 вместо 6 371 009 из Вики)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Итак. на повестке изображения аватаров. Что говорят правила? • Запрещено: 3.2. … Создавать аватары порнографического, политического или религиозного содержания. Администрация вправе удалить такого пользователя без предупреждения. Также есть запрет на рекламу к в том числе в качестве аватара.
Что делать, например, с такими автарами? Мне, например, очень не нравится эта всратая бабка. Она страшная, неприятная. Я бы не хотел, чтобы подобное было у меня тут в ленте. Я не вижу ни единой причины ставить такое в качестве своего аватара — я бы таких людей проверял на психические отклонения.
А, если на форум зайдёт ребёнок? У нас полно обучающих Приёмов и видео. Я не моралфаг, но у нас же не двач или фочан (ничего против них не имею, кстати), чтобы подобное считалось нормой.
А если, кто-то поставит на аватар изображение трупа/казни? Есть ещё эротика (не порнография). Также, можно в качестве аватара использовать изображение или даже гифку дефекации (есть ещё легендарное видео с банкой) и прочих "интересных" для общества явлений. На данный момент, это в рамках правил.
Почему бы не использовать давно придуманную норму NSFW (Not Safe/Suitable For Work) или обобщить правила до "уместных" (определяется модераторами) для общественного (можно даже сказать "образовательного") форума изображений?
А то, распятие, которое многие на шее показательно носят (иногда — огромного размера), я не могу поставить (не то, чтобы я хотел — это просто пример), зато всякую погань — пожалуйста.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Решил агрегировать у себя сборник вариантов по различным "обобщениям" строк между собой. Тут будут храниться ссылки на темы (если оттуда) и последние версии моих кодов (возможно, некоторые будут обновляться здесь).
Начинаю с 2ух чужих тем т.к. очень интересен алгоритм решения задач. В обоих есть мои и чужие решения.
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=161168&TITLE_SEO=161168-poisk-konsensusnoy-posledovatelnosti
'==================================================================================================
Private Function JF_MainString_Matrix(rngIn As Range, sOut$) As Boolean
Dim x, aMatrix&(), aJ$(), aBt() As Byte, aComp&()
Dim n&, r&, c&, b&, l&, lMax&, chSym&, chMax&, chCount&, chRate&
n = rngIn.Cells.CountLarge
If (n = 1) Then JF_MainString_Matrix = rngIn.Value2: Exit Function
chMax& = 122 ' TableMaxSym
ReDim aComp(chMax)
ReDim aMatrix(n, 100): n = 0
For Each x In rngIn.Value2
If (VarType(x) <> vbString) Then GoTo nx
If (x = "") Then GoTo nx
chSym = AscW(x): If (chSym > chMax) Then chMax = 1105: ReDim Preserve aComp(chMax)
aComp(chSym) = aComp(chSym) + 1
If (aComp(chSym) > chCount) Then chCount = aComp(chSym): chRate = chSym
aBt = x: l = 0.5 * (UBound(aBt) + 1)
If (lMax < l) Then lMax = l
If (l = 1) Then GoTo nx
c = 0: n = n + 1
For b = 2 To UBound(aBt) - 1 Step 2
c = c + 1: aMatrix(n, c) = aBt(b) + 256 * aBt(b + 1)
Next b
nx:
Next x
If (chRate <> 0) Then JF_MainString_Matrix = True Else Exit Function
If (n = 0) Then sOut = ChrW$(chRate): Exit Function
' Variant on JoinArray(same Time) ---------------
ReDim aJ(lMax): aJ(1) = ChrW$(chRate)
For c = 1 To lMax - 1
ReDim aComp(chMax): chCount = 0: chRate = 0
For r = 1 To n
If (aMatrix(r, c) <> 0) Then
chSym = aMatrix(r, c)
aComp(chSym) = aComp(chSym) + 1
If (aComp(chSym) > chCount) Then chCount = aComp(chSym): chRate = chSym
End If
Next r
If (chRate = 0) Then Stop: End
aJ(c + 1) = ChrW$(chRate)
Next c
sOut = Join(aJ, "")
End Function
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=160990&TITLE_SEO=160990-naibolee-dlinnaya-podstroka
'==================================================================================================
Private Function pv_Rng_GetUniqStrings(rngIn As Range, lMin_Out&, sMin_Out$, aStrOth_Out() As String) As Boolean
Dim x, arr, a&, l&, n&, nMin&
Static dic As New Dictionary
ReDim aStrOth_Out(rngIn.Cells.CountLarge)
lMin_Out = 40000
For a = 1 To rngIn.Areas.Count
arr = rngIn.Areas(a).Value2
If Not IsArray(arr) Then arr = Array(arr)
For Each x In arr
If (VarType(x) <> vbString) Then GoTo nx
If (x = "") Then GoTo nx
If dic.Exists(x) Then GoTo nx
n = n + 1: aStrOth_Out(n) = x
dic.add aStrOth_Out(n), 0
l = Len(aStrOth_Out(n)): If (lMin_Out > l) Then lMin_Out = l: nMin = n
Next x
nx:
Next a
dic.RemoveAll: If (nMin = 0) Then Exit Function
sMin_Out = aStrOth_Out(nMin)
For a = nMin + 1 To n
aStrOth_Out(a - 1) = aStrOth_Out(a)
Next a
ReDim Preserve aStrOth_Out(n - 1)
pv_Rng_GetUniqStrings = True
End Function
'--------------------------------------------------------------------------------------------------
Private Function pv_MainSubString(lMin_In&, sMin_In$, aStrOth_In() As String, lMax_Out&, sSubStr_Out$) As Boolean
Dim sSrch$, n&, i&, lSrch&
lMax_Out = 0: i = 1: lSrch = 1
Do
rp: sSrch = Mid$(sMin_In, i, lSrch)
For n = 1 To UBound(aStrOth_In)
If (InStr(aStrOth_In(n), sSrch) = 0) Then
If (lMax_Out >= lMin_In - i) Then GoTo ex
i = i + 1: lSrch = 1: GoTo rp
End If
Next n
If (lMax_Out < lSrch) Then lMax_Out = lSrch: sSubStr_Out = sSrch
If (lMin_In = i + lSrch - 1) Then GoTo ex Else lSrch = lSrch + 1
Loop
ex: If (lMax_Out <> 0) Then pv_MainSubString = True
End Function
'--------------------------------------------------------------------------------------------------
Private Function MainSubString(rng As Range) As String
Dim aStr$(), sMin$, lMin&, lMax&
If Not pv_Rng_GetUniqStrings(rng, lMin, sMin, aStr) Then Exit Function
pv_MainSubString lMin, sMin, aStr, lMax, MainSubString
End Function
'==================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Последние несколько лет периодически возвращаюсь к идее создания "единой сметы". Я постоянно работаю со сметными данными и наличие разнообразных форм вывода (а также их изменение) сметной информации сильно усложняет процесс стандартизации сбора информации, а также плодит ошибки "человеческого фактора". А что, если будет создана сметная программа (или закон, позволяющий принимать сметы только в таком виде), которая позволит создавать файл (пока в приоритете xml формат), содержащий ВСЮ НЕОБХОДИМУЮ информацию о смете в заданном виде/структуре. Позволяющем ОДНООБРАЗНО обрабатывать (получать информацию) из ЛЮБОЙ сметы, созданной в соответствии с законодательством.
Более того, пока я думал, нечто подобное уже ввели (ГлавГосЭкспертиза, МинСтрой), НО основные проблемы решены НЕ БЫЛИ:
• постоянные изменения формата. Главная головная боль. Этого быть не должно. Информация должна находиться на своих местах. Если нужно ДОБАВИТЬ какую-то новую информацию, то должно быть выпущено ПОЛНОЦЕННОЕ ОПИСАНИЕ нового формата XML и ПОДРОБНОЕ СРАВНЕНИЕ с картинками отличий его от старого формата. Если какая-то информация потеряла свою актуальность, то её тэги в структуре просто будут пустыми. Это позволит создавать инструменты, собирающие данные из самых "новых" и самых "старых" смет в XML-формате. В идеале, со стороны государства должен поставляться и обновляться вместе с очередным форматом РАЗБОРЩИК, позволяющий представить информацию из XML в ЛЮБОМ необходимом виде (смета, ведомость ресурсов, расчёт стоимости ресурсов). Также. нет никакой технической сложности разработать универсальный сметный формат, включающий ВСЮ информацию на одном листе (в одном документе) без разбивки на саму смету и ведомость ресурсов. Сейчас же ситуация такая, что данные на разных "официальных" ресурсах отличаются между собой и все вместе отличаются от данных из официального приказа (привет, КСР и ФССЦ). Это должно быть исключено. Надзорный орган ОБЯЗАН ГАРАНТИРОВАТЬ ЕДИНОЕ место хранения информации, её ПОЛНОЕ СООТВЕТСТВИЕ приказам и возможность получения её в XML-формате.
• несоответствие данных между собой Если раньше код сметы из листа Source (сырые данные из программы) и в самой смете могли отличаться или сумма ресурсов из ведомости не равна сумме ресурсов из сметы, то сейчас происходит то же самое, но уже в новом XML-формате. Старые болячки не вылечены. Решение простое: когда данные предоставлены в строгом формате с известной структурой, то несложно написать (включить в официальный разборщик) программу, которая выполнит все необходимые проверки и АВТОМАТИЧЕСКИ отклонит некорректные XML. Это существенно ускорит и удешевит процесс проверки. На данный момент, огромное количество (более 80%) смет, прошедших экспертизу, содержат ГРУБЕЙШИЕ ошибки и нестыковки на огромные суммы. Возникает закономерный вопрос: а в чём, собственно, тогда была "экспертиза"…
• несоответствие ключей ресурсов справочникам или отсутствие таких ключей Проблема не относится к теме напрямую, но обозначу. Существует ОГРОМНАЯ потребность в ЕДИНОМ и ПОПОЛНЯЕМОМ (не изменяемом) справочнике ресурсов, с критерием актуальности ключа (вместо его удаления или, боже упаси, замены) и НЕИЗМЕННОЙ структурой. Опять же, технической сложности в создании такого справочника нет. Есть только проблема в сборе информации и категоризации ресурсов (всё решаемо). Основная проблема на данный момент, состоит в том, что созданием подобных справочников занимаются люди НЕВЕРОЯТНО ДАЛЁКИЕ от понимания БАЗОВЫХ ПРАВИЛ организации любого справочника.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Наткнулся на интересную статью (на хабре). Мне было интересно узнать [часто, совсем неочевидную] историю происхождения известных терминов.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Универсальный парсер текстовых файлов(строк) с тэговой структурой типа XML/HTML с получением результата в двумерный массив и полным сохранением структуры, Parse XML/HTML to Array-2D
Занялся созданием парсера, т.к. на работе возникла необходимость в частой обработке XML-документов. Предполагается, что по двумерному массиву (результат работы парсера) будет возможна полная обратная конвертация в исходную структуру XML/HTML. Разработка парсера ведётся на основе XML-документа "ГЭСН". Парсер НЕ будет использовать библиотеку XML-DOM.
В файле — визуализация конечного результата (двумерный массив) на листе с цветовой индикацией (только для визуала). Присутствует ссылка на родительский ID — иерархия.
Если к теме/инструменту будет интерес, то Виталий «BedVit» подумает над созданием [куда более быстрого] аналога в своей библе.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Мне тут прозрачно намекнули , что ничего в старом описании было непонятно, поэтому напишу примерный ход разработки по порядку.
Описание
Итак, быстрее всего (с оговороками) проверить символ на вхождение в список можно, используя его десятичный ЮниКод в качестве индексов массива. Так, чтобы проверка arr(UniCode) = 1 означала наличие символа с кодом UniCode в списке. Понять, как лучше всего использовать массив для этой задачи и было моей целью.
Какой массив использовать? Тесты показали, что по скорости запись/чтение Long, Boolean и Byte равны (и заметно быстрее других — ну тут понятно). Взял байтовый, т.к. он должен занимать меньше всего места (в 2 раза меньше, чем булевый и в 4 раза меньше, чем лонг).
С массивом разобрался. А как пользователю этот массив наполнить? Пользователь будет передавать список обычным способом — строкой типа "абвгд" (вот эти символы нужно проверять). Тут ничего сложного — пишу функцию для конвертации строки в Long-массив размером с количество символов в строке. Тут я вспоминаю про инструмент FilterUnicodeChar в библе Виталия «BedVit», который позволяет передавать символы диапазонами, а также передать дополнительный список для исключения из основного. Ну то есть, можно передать "а-я" (все символы от "а" до "я" включительно) и исключаем из него "вдз-л" ("в", "д" и от "з" до "л"). Очевидно, это намного проще, чем передавать "а-бге-жм-я". Тут прям думать пришлось…
Добавил в функцию возможность работы с диапазонами. В качестве разделителя диапазонов используется обычный минус/тире/дефис AscW("-") = 45. Для того, чтобы дефис считался символом, а не разделителем, он должен быть в начале строки, конце строки или являться частью диапазона: "--0" (от минуса до нуля). При указании диапазона символов, символ "от" должен быть строго меньше (его десятичный код по юникоду) чем "до". Иначе, будет ошибка.
Теперь я могу конвертировать строку символов от пользователя в одномерный лонг-массив с десятичными юникодами этих символов в качестве значений. Но это всё ещё не позволяет выполнить проверку arr(UniCode) = 1… Делаю функцию по наполнению "полного" массива (0 To 65 535) юникод-символов единичками, "напротив" (в качестве значений) тех индексов, юникод-символы которых соответствуют переданным строкам "включения" и (опционально) "исключения".
Теперь, чтобы определить символ на вхождение в список, нужно просто проверить массив на If arr(CodeSymbol) = 1 Then. Это быстрее, чем InStr (есть сравнение) или Dictionary (по определению, получение значения массива по его индексу быстрее словаря или каких бы то ни было аналогов).
Присутствуют тесты для каждой функции — для визуализации работы. Сравнение сделал на реальной задаче "Удалить из начала и/или конца строки символы, согласно списка" — в конце портянки кода. Добавил файл с кодом и таблицей первых 8 000 (чуть больше) символов — для того, чтобы был понятен порядок и корректно указывались диапазоны символов. Присутствует разбитие на группы и цветовая индикация. Местами, есть комментарии.
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Forum: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=159628&TITLE_SEO=159628-bystroe-opredeleniya-vkhozhdeniya-simvola-v-spisok
'==================================================================================================
' 1st Byte Index = 2 * (nSym - 1)
' nSym = (1st Byte Index / 2) + 1
' UniNum = 1st Byte + (256 * 2nd Byte)
'==================================================================================================
Const vc_ULast& = 65535
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub Test_UniList()
Dim s$, n&
On Error Resume Next
For n = 0 To 100000
s = ChrW$(n)
If Err.Number <> 0 Then n = n - 1: Exit For
Next n
On Error GoTo 0
Debug.Print n ' 65 535
End Sub
'==================================================================================================
Private Sub TestSpeed_ArrType()
Dim t!, n&, res&
Const nCyc& = 100000000 ' 100 mln
' Keep ONE Variant | Fill | Get
'Dim a '| 3.0 | 3.6
'Dim a() '| 1.3 | 1.4
'Dim a&() '| 0.9 | 0.9
'Dim a() As Boolean '| 0.9 | 0.9
'Dim a() As Byte '| 0.9 | 0.9
ReDim a(nCyc)
t = Timer
For n = 1 To nCyc
a(n) = 1
Next n
Debug.Print Format$(Timer - t, "0.0"), "Fill"
t = Timer
For n = 1 To nCyc
res = a(n)
Next n
Debug.Print Format$(Timer - t, "0.0"), "Get"
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
' Engine
'==================================================================================================
Function String_UniList_ToArr1D(sIn$, aOut() As Long, Optional UseRanges As Boolean) As Boolean
Dim aBt() As Byte, lastBt&, b&, u&, uPrev&, uNext&, n&, p&
aBt = sIn
lastBt = UBound(aBt) - 1
If ((UseRanges) And (InStr(sIn, "-") <> 0)) Then
ReDim aOut(1000) ' I can't imagine that i need more then 1000 symbols for that
For b = 0 To lastBt Step 2
u = aBt(b) + (256 * aBt(b + 1))
If u <> 45 Then n = n + 1: aOut(n) = u: GoTo nx ' Ascw("-") = 45
If ((b = 0) Or (b = lastBt)) Then n = n + 1: aOut(n) = u: GoTo nx
uPrev = aBt(b - 2) + (256 * aBt(b - 1))
uNext = aBt(b + 2) + (256 * aBt(b + 3))
If uPrev >= uNext Then MsgBox "Range ERROR with String:" & vbLf & sIn & vbLf & vbLf & "Symbol #" & Format$(n, "#,#") & " «" & ChrW$(uPrev) & "»(" & uPrev & ")" & vbLf & "must be LESS then" & vbLf & "Symbol #" & Format$(n + 2, "#,#") & " «" & ChrW$(uNext) & "»(" & uNext & ")", vbCritical, "String_UniList_ToArr1D": Exit Function
For p = uPrev + 1 To uNext
n = n + 1: aOut(n) = p
Next p
b = b + 2
nx: Next b
ReDim Preserve aOut(n)
Else
ReDim aOut(Len(sIn))
For b = 0 To lastBt Step 2
n = n + 1
aOut(n) = aBt(b) + (256 * aBt(b + 1))
Next b
End If
String_UniList_ToArr1D = True
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_String_UniList_ToArr1D()
Dim a&(), s$, n&, UseRanges As Boolean
UseRanges = True ' Comment for simple List withot Ranges
' Choose ONE Variant (comment other) or use last
s = "-0" ' 2 Sym
s = "--0" ' 4 Sym: From "-" To "0"
s = "--0-" ' 5 Sym: From "-" To "0" and "-"
's = "---0" ' Error Range. MsgShow. Because "-" is Equal "-"
's = "--0-3" ' 7 Sym: From "-" To "0" and From "0" To "3". Same like "--3"
's = "0-5f-l" ' 13 Sym: From "0" To "5" and From "f" To "l"
's = "0-0" ' Error Range. MsgShow. Because "0" is Equal "0"
's = "1-0" ' Error Range. MsgShow. Because "1" is Bigger then "0"
If Not String_UniList_ToArr1D(s, a, UseRanges) Then Exit Sub
For n = 1 To UBound(a)
Debug.Print n, a(n), ChrW$(a(n))
Next n
End Sub
'==================================================================================================
'==================================================================================================
Function String_UniList_ToArr1D_ExistsInFull(aOut_LB0() As Byte, sOn_In$, Optional sOff_In$, Optional UseRanges As Boolean) As Boolean
Dim a&(), n&
ReDim aOut_LB0(0 To vc_ULast) ' vc_ULast = 65 535 is Last UniCode for ChrW$()
' On ============================================
If Not String_UniList_ToArr1D(sOn_In, a, UseRanges) Then Exit Function
For n = 1 To UBound(a)
aOut_LB0(a(n)) = 1
Next n
' Off ===========================================
If sOff_In = "" Then GoTo fin
If Not String_UniList_ToArr1D(sOff_In, a, UseRanges) Then Exit Function
For n = 1 To UBound(a)
aOut_LB0(a(n)) = 0
Next n
fin: String_UniList_ToArr1D_ExistsInFull = True
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_String_UniList_ToArr1D_ExistsInFull()
Dim a() As Byte, sOn$, sOff$, n&, tot&, UseRanges As Boolean
UseRanges = True ' Comment for simple List withot Ranges
' Choose ONE Variant (comment other) or use last
'sOn = "a-z": sOff = "dgow"
sOn = "-a-z": sOff = "d-ow"
'sOn = "a-z-": sOff = "d-w"
'sOn = "0-z": sOff = "A-Z:-`"
'sOn = "0-3-8": sOff = ""
'sOn = "--8": sOff = ""
If Not String_UniList_ToArr1D_ExistsInFull(a, sOn, sOff, UseRanges) Then Exit Sub
For n = 0 To UBound(a)
If a(n) = 1 Then tot = tot + 1: Debug.Print n, ChrW$(n)
Next n
If tot <> 0 Then Debug.Print "Total:", Format$(tot, "#,#")
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
' Real Task. Del symbols in String by Begin and/or End
'==================================================================================================
Sub String_DelLR_InStr(sIn$, sOut$, Optional sL$, Optional sR$, Optional fL As Boolean, Optional fR As Boolean)
sOut = Trim$(sIn): If sOut = "" Then Exit Sub
If fL Then
Do While (InStr(sL, Left$(sOut, 1)) <> 0)
sOut = Trim$(Right$(sOut, Len(sOut) - 1)): If sOut = "" Then Exit Sub
Loop
End If
If fR Then
Do While (InStr(sR, Right$(sOut, 1)) <> 0)
sOut = Trim$(Left$(sOut, Len(sOut) - 1)): If sOut = "" Then Exit Sub
Loop
End If
End Sub
'--------------------------------------------------------------------------------------------------
Sub String_DelLR_AscW(sIn$, sOut$, aL() As Byte, aR() As Byte, Optional fL As Boolean, Optional fR As Boolean)
Dim aBt() As Byte, ll&, b&, l&, r&
sOut = Trim$(sIn)
ll = Len(sIn): If ll = 0 Then Exit Sub
aBt = sIn
If fL Then
For b = 0 To UBound(aBt) Step 2
If aL(aBt(b) + (256 * aBt(b + 1))) = 1 Then l = l + 1 Else Exit For
Next b
End If
If l = ll Then sOut = "": Exit Sub
If fR Then
For b = UBound(aBt) - 1 To 0 Step -2
If aR(aBt(b) + (256 * aBt(b + 1))) = 1 Then r = r + 1 Else Exit For
Next b
End If
If ((l + r) <> 0) Then sOut = Mid$(sOut, l + 1, ll - l - r)
End Sub
'--------------------------------------------------------------------------------------------------
Sub String_DelLR_AscW_OneSym(sIn$, sOut$, Optional nL& = -1, Optional nR& = -1)
Dim aBt() As Byte, ll&, b&, l&, r&
sOut = Trim$(sIn)
ll = Len(sOut): If ll = 0 Then Exit Sub
aBt = sOut
If nL > -1 Then
For b = 0 To UBound(aBt) Step 2
If nL = (aBt(b) + (256 * aBt(b + 1))) Then l = l + 1 Else Exit For
Next b
End If
If l = ll Then sOut = "": Exit Sub
If nR > -1 Then
For b = UBound(aBt) - 1 To 0 Step -2
If nR = (aBt(b) + (256 * aBt(b + 1))) Then r = r + 1 Else Exit For
Next b
End If
If ((l + r) <> 0) Then sOut = Mid$(sOut, l + 1, ll - l - r)
End Sub
'--------------------------------------------------------------------------------------------------
'--------------------------------------------------------------------------------------------------
Private Sub Test_String_DelLR()
Dim aL() As Byte, aR() As Byte
Dim s$, s2$, sList$, t!, n&
sList$ = ".,/|\:-"
s = "sdgfsgsdfsdfsdfsdfsdf"
s = sList & s & StrReverse(sList)
t = Timer
String_UniList_ToArr1D_ExistsInFull aL, sList: aR = aL
Debug.Print Format$(Timer - t, "0.00"), "Create Arrays for AscW method" ' 0.00
t = Timer
For n = 1 To 1000000
' String_DelLR_InStr s, s2, sList, sList, True, True ' 3.0
' String_DelLR_AscW s, s2, aL, aR, True, True ' 1.1
' String_DelLR_AscW_OneSym s, s2, 46, 46 ' 0.6
Next n
Debug.Print Format$(Timer - t, "0.0"), s2
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Небольшое наблюдение: хотел ускорить проверку на [возможные] числовые значения или просто ускорить отсев ошибок и пустых.
Что касается отбора [возможных] числовых значений: вариант "в лоб" (с помощью супербыстрой IsError() ) совсем незначительно (можно пренебречь) медленнее использования способности IsNumeric() к встроенному пропуску ошибок. А вот, при простом отсеве ошибок и пустых, отказываться от явной проверки (в пользу пропуска ошибок) уже точно не стоит. Дольше в 4 раза на примере.
У кого есть что добавить (по теме) — обсудим
Тестовый код
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub t()
Dim x, a(4), t!, n&, p&
Const nCyc& = 10000000 ' 10 mln
a(1) = CVErr(xlErrNA)
a(2) = 1
a(3) = "abc"
'a(4) = Empty
' Find Num ======================================
' 1
p = 0: t = Timer
For n = 1 To nCyc
For Each x In a
If IsError(x) Then GoTo nx1
If Len(x) = 0 Then GoTo nx1
If Not IsNumeric(x) Then GoTo nx1
p = p + 1
nx1: Next x
Next n
Debug.Print 1, Format$(Timer - t, "0.0"), p ' 4.6 | 10 mln
' 2
p = 0: t = Timer
For n = 1 To nCyc
For Each x In a
If Not IsNumeric(x) Then GoTo nx2
If Len(x) = 0 Then GoTo nx2
p = p + 1
nx2: Next x
Next n
Debug.Print 2, Format$(Timer - t, "0.0"), p ' 4.2 | 10 mln
' Find NotErrorAndEmpty =========================
'3
p = 0: t = Timer
For n = 1 To nCyc
For Each x In a
If IsError(x) Then GoTo nx3
If Len(x) = 0 Then GoTo nx3
p = p + 1
nx3: Next x
Next n
Debug.Print 3, Format$(Timer - t, "0.0"), p ' 4.0 | 20 mln
'4
p = 0: t = Timer
On Error Resume Next
For n = 1 To nCyc
For Each x In a
If Len(x) = 0 Then GoTo nx4
p = p + 1
nx4: Next x
Next n
Debug.Print 4, Format$(Timer - t, "0.0"), p ' 15.3 | 20 mln
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Как определить, отключён ли Application.StatusBar (штатное состояние) или в нём написано "FALSE", How to distinguish between «Application.StatusBar = False» and «Application.StatusBar = "False"»
Приветствую! При получении Application.StatusBar в вариативную переменную, это всегда строка. Отсюда возникает неопределённость — как отделить штатное состояние False от присвоенного значения "False"? Проверка Application.StatusBar = False тоже срабатывает и на строку.
Пока что сделал проверку с гарантированным присвоением
Код
Function PRDX_StatusBar_IsBusy() As Boolean
If Application.StatusBar = False Then Application.StatusBar = False Else PRDX_StatusBar_IsBusy = True
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Решил тут проверить кое-что для себя и зафиксировать тут Если тип передачи аргумента не указывается, то по умолчанию используется ByRef. Иными словами, только передача аргумента значением нуждается в явном указании — ByVal. Передача аргумента по ссылке избегает его (аргумента) копирования и позволяет изменять передаваемые аргументы. Нельзя передать значением (ByVal) аргументы массивов, Но можно передавать значением аргумент типа Variant, в который запросто можно передать массив.
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Function f_ByRef(s$) As Long
f_ByRef = InStr(s, "b")
End Function
'==================================================================================================
Private Function f_ByVal(ByVal s$) As Long
f_ByVal = InStr(s, "b")
End Function
'==================================================================================================
Private Function f_Var(s) As Long
f_Var = InStr(s, "b")
End Function
'==================================================================================================
Private Function f_Var2(s) As Long
Dim ss$: ss = s
f_Var2 = InStr(ss, "b")
End Function
'==================================================================================================
Private Function f_Var3(ByVal s) As Long
f_Var3 = InStr(s, "b")
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub Test()
Dim v, aVar(1), aStr$(1), t!, s$, res&, n&
Const nCyc& = 10000000 ' 10 mln
s = "bob"
v = s: aVar(1) = s: aStr(1) = s
t = Timer ' s
For n = 1 To nCyc
' res = f_ByRef(s) ' 0.6
' res = f_Var(s) ' 0.8
' res = f_ByVal(s) ' 1.4
' res = f_Var2(s) ' 1.4
res = f_Var3(s) ' 1.7
Next n
Debug.Print Format$(Timer - t, "0.0"), res
't = Timer ' aStr$()
' For n = 1 To nCyc
' res = f_ByRef(aStr(1)) ' 0.6
' res = f_Var(aStr(1)) ' 0.8
' res = f_ByVal(aStr(1)) ' 1.4
' res = f_Var2(aStr(1)) ' 1.5
' res = f_Var3(aStr(1)) ' 1.7
' Next n
'Debug.Print Format$(Timer - t, "0.0"), res
't = Timer ' v
' For n = 1 To nCyc
' res = f_Var(v) ' 0.8
' res = f_ByRef(CStr(v)) ' 1.0
' res = f_ByVal(v) ' 1.4
' res = f_Var2(v) ' 1.4
' res = f_Var3(v) ' 1.6
' Next n
'Debug.Print Format$(Timer - t, "0.0"), res
't = Timer ' aVar()
' For n = 1 To nCyc
' res = f_Var(aVar(1)) ' 0.8
' res = f_ByRef(CStr(aVar(1))) ' 1.1
' res = f_ByVal(aVar(1)) ' 1.5
' res = f_Var2(aVar(1)) ' 1.5
' res = f_Var3(aVar(1)) ' 1.7
' Next n
'Debug.Print Format$(Timer - t, "0.0"), res
End Sub
Test Long (намного более непонятная картина)
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Function f_ByRef(n&) As Boolean
f_ByRef = (n <> 0)
End Function
'==================================================================================================
Private Function f_ByVal(ByVal n&) As Boolean
f_ByVal = (n <> 0)
End Function
'==================================================================================================
Private Function f_Var(n) As Boolean
f_Var = (n <> 0)
End Function
'==================================================================================================
Private Function f_Var2(n) As Boolean
Dim nn&: nn = n
f_Var2 = (nn <> 0)
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub Test()
Dim v, t!, l&, n&, f As Boolean
Const nCyc& = 10000000 ' 10 mln
l = 1: v = l
t = Timer ' l
For n = 1 To nCyc
f = f_ByRef(l) ' 0.5
' f = f_ByVal(l) ' 0.5
' f = f_Var2(l) ' 0.6
' f = f_Var(l) ' 1.1
Next n
Debug.Print Format$(Timer - t, "0.0"), f
't = Timer ' v
' For n = 1 To nCyc
' f = f_ByRef(CLng(v)) ' 0.5
' f = f_ByVal(v) ' 0.5
' f = f_Var2(v) ' 0.6
' f = f_Var(v) ' 1.1
' Next n
'Debug.Print Format$(Timer - t, "0.0"), f
End Sub
'==================================================================================================
'==================================================================================================
Тесты показывают: • вариативный аргумента (по ссылке) — универсален. Чуть медленнее строгого типа, зато быстрее при несовпадении типов. • если строго ожидается и передаётся строка по ссылке, то это быстрее всего, но для других типов (если перед передачей понадобиться преобразование) будет медленнее вариативного аргумента. • по скорости передача значением равна присвоению "нужной" переменной внутри процедуры/функции, а это довольно медленно.
Также, плюсом вариативного аргумента является то, что его очень легко можно проверить на IsMissing(), если он опциональный — то есть был ли передан аргумент пользователем. Например, в случае опционального лонга, его НЕпередача и его передача со значением 0 ничем не будут отличаться (если значение по умолчанию для опционального аргумента не задано или задано 0) и проверить будет просто невозможно (насколько мне известно).
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Есть функция (идея не моя), которая генерирует условно-уникальные (возможны ситуации получения дублей) числовые (_451216832870371) ключи на основе текущей дата-времени компа. Хотелось бы сократить длину ключа при полном сохранении его значения (возможности обратной конвертации). Посчитал, что для этого должны подойти буквы, но, если есть другие предложения, то всё рассмотрю (и попрошу сменить название темы при необходимости). Жду ваши алгоритмы шифровки-дешифровки и пока подумаю сам.
Требования к алгоритму
• алгоритм шифровки должен однозначно получать новый ключ • алгоритм ДЕшифровки должен однозначно получать исходный ключ • при шифровке новый ключ должен быть короче оригинала • в качестве букв может использоваться только латиница в ВЕРХНЕМ регистре "A-Z" (ключи "ABC" и "abc" считаются идеинтичными).
Код
Код
Function PRDX_KeyCreate() As String
Static old#
If old = 0 Then old = Fix(Now * 10000000000#) Else old = old + 1
PRDX_KeyCreate = "_" & old
End Function
UPD: Решено по совету от Marat Ta с помощью функции MCHотсюда. Теперь, при конвертации из 10 в 36 систему ключ "худеет" на треть: с 15 до 10 символов. Годится
Функция от MCH (причесал под себя)
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' by MCh: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=76392&TITLE_SEO=76392-perevod-chisla-s-odnoy-sistemy-schisleniya-v-druguyu-vba&MID=657676#message657676
'==================================================================================================
Function PRDX_Num_BaseToBase(sNum$, BaseFrom&, BaseTo&) As String
Dim A&(0 To 100000), B&, C&, L&
Dim s$, i&, j&, k&
For i = 1 To Len(sNum)
j = -1
While j < L Or C > 0
j = j + 1
B = A(j) * BaseFrom + C
A(j) = B Mod 10000
C = B \ 10000
Wend
L = j
C = AscW(UCase$(Mid$(sNum, i, 1)))
If C <= 57 Then C = C - 48 Else C = C - 55
j = -1
While C > 0
j = j + 1
B = A(j) + C
A(j) = B Mod 10000
C = B \ 10000
Wend
If j > L Then L = j
Next i
Do
B = 0
For i = L To 0 Step -1
B = (B * 10000 + A(i)) Mod BaseTo
Next i
If B < 10 Then B = B + 48 Else B = B + 55
k = k + 1: If k > Len(s) Then s = s & Space$(1000)
Mid$(s, k, 1) = ChrW$(B)
C = 0: j = L
For i = L To 0 Step -1
B = C * 10000 + A(i)
A(i) = B \ BaseTo
C = B Mod BaseTo
If A(i) = 0 And i = L Then j = i - 1
Next i
L = j
Loop While L >= 0
PRDX_Num_BaseToBase = StrReverse(Left$(s, k))
End Function
Тест работоспособности
Скрин
Код
Код
Private Sub Test_KeyConvert()
Dim BAI As New BedvitCOM.BignumArithmeticInteger
Dim s$, s2$, s3$
s = Mid$(PRDX_Key_Num_Create, 2): Debug.Print "Base10", Len(s), s
s2 = PRDX_Num_BaseToBase(s, 10, 36): Debug.Print "Base36", Len(s2), s2
s3 = PRDX_Num_BaseToBase(s2, 36, 10): Debug.Print "Base10", Len(s3), s3
s2 = "": s3 = ""
BAI.Bignum(1, 10) = s: s2 = BAI.Bignum(1, 36)
BAI.Bignum(2, 36) = s2: s3 = BAI.Bignum(2, 10)
Debug.Print vbLf
Debug.Print "BV.Base36", Len(s2), s2
Debug.Print "BV.Base10", Len(s3), s3
End Sub
Сравнение скоростей. Библа около 80ти раз быстрее.
Скрин
Код
Код
Private Sub Test_Speed()
Dim BAI As New BedvitCOM.BignumArithmeticInteger
Dim s$, s2$, s3$, t!, n&
Const nCyc& = 100000 ' 100k
s = Fix(Now * 10000000000^)
t = Timer
For n = 1 To nCyc
s2 = PRDX_Num_BaseToBase(s, 10, 36)
s3 = PRDX_Num_BaseToBase(s2, 36, 10)
Next n
Debug.Print Format$(Timer - t, "0.00"), "MCH", s, s2, s3 ' 5.77
t = Timer
For n = 1 To nCyc
BAI.Bignum(1, 10) = s: s2 = BAI.Bignum(1, 36)
BAI.Bignum(2, 36) = s2: s3 = BAI.Bignum(2, 10)
Next n
Debug.Print Format$(Timer - t, "0.00"), "BV", s, s2, s3 ' 0.07
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Интересует мнение постоянных помогающих — тех, за чей счёт форум вообще живёт. Как вы считаете - наличие подобных тем приемлемо для сайта? Я — категорически против.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Возникла необходимость в очередном инструменте. Аналог на существующих процедурах невероятно медленный (в 6 раз на примере). Его можно ускорить, если метод из библы ArrayReDim будет дополнительно получать массив для вывода aOut (сейчас массив aInOut используется для ввода и вывода). Однако, думаю, что отдельный инструмент по типу моей процедуры на VBA будет заметно быстрее (и не придётся писать оболочку). Если, конечно, в библу вообще возможна передача неопределённого количества параметров, как ParamArray…
bedvit, кстати говоря, я рекомендую все процедуры, работающие с массивом "на месте" переделать под передачу массива вывода и предусмотреть возможность передачи в качестве ввода и вывода одного и того же массива, если это позволяет логика процедуры. Копирование больших массивов всё же не мгновенная операция и, как мы видим, порой, совершенно лишняя.
Тест
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub PRDX(a2D, rStart&, rFin&, aColNums, ParamArray aCols())
Dim a(), r&, rr&, i&, ofs&, nCol&
If rStart < 1 Then rStart = 1
If rFin < rStart Then rFin = UBound(a2D, 1)
ReDim a(rFin - rStart + 1)
If Not IsArray(aColNums) Then aColNums = Array(aColNums) Else ofs = LBound(aColNums) - 1
For i = 0 To UBound(aCols)
rr = 0: ofs = ofs + 1: nCol = aColNums(ofs)
For r = rStart To rFin
rr = rr + 1: a(rr) = a2D(r, nCol)
Next r
aCols(i) = a
Next i
End Sub
'==================================================================================================
Private Sub BedVit(a2D, rStart&, rFin&, aColNums, ParamArray aCols())
Dim Bed As New BedvitCOM.VBA
Dim UBr&, UBc&, cutBeg&, cutEnd&, i&, ofs&, nCol&
UBr = UBound(a2D, 1): UBc = UBound(a2D, 2)
If rStart > 1 Then cutBeg = rStart - 1
If rFin > 0 Then cutEnd = UBr - rFin
If Not IsArray(aColNums) Then aColNums = Array(aColNums) Else ofs = LBound(aColNums) - 1
Bed.Array2Dto1D a2D, 1
For i = 0 To UBound(aCols)
ofs = ofs + 1: nCol = aColNums(ofs)
aCols(i) = a2D: Bed.ArrayReDim aCols(i), 1, UBr * (1 - nCol) - cutBeg, UBr * (nCol - UBc) - cutEnd
Next i
End Sub
'==================================================================================================
'==================================================================================================
Private Sub Test()
Dim a2D, aCol, a1, a2, a3
Dim t!, r&, c&, rBeg&, rEnd&
Const rLim& = 1000000, cLim& = 10
aCol = Array(2, 4, 6)
ReDim a2D(rLim, cLim)
rBeg = 11: rEnd = rLim - 100 ' From r #11 to 999 900 = 999 890 elements in each a1D
t = Timer
For c = 1 To cLim
For r = 1 To rLim
a2D(r, c) = r & "•" & c
Next r
Next c
Debug.Print Format$(Timer - t, "0.0"), "CreateArr", vbLf ' 3.5
t = Timer
PRDX a2D, rBeg, rEnd, aCol, a1, a2, a3
Debug.Print Format$(Timer - t, "0.0"), "PRDX" ' 0.9
Debug.Print UBound(a1) & " | " & UBound(a2) & " | " & UBound(a3): r = UBound(a1) ' 999890 | 999890 | 999890
Debug.Print a1(1) & "-" & a1(r) & " | " & a2(1) & "-" & a2(r) & " | " & a3(1) & "-" & a3(r), vbLf ' 11•2-999900•2 | 11•4-999900•4 | 11•6-999900•6
Erase a1: Erase a2: Erase a3
t = Timer
BedVit a2D, rBeg, rEnd, aCol, a1, a2, a3
Debug.Print Format$(Timer - t, "0.0"), "BedVit" ' 5.5
Debug.Print UBound(a1) & " | " & UBound(a2) & " | " & UBound(a3): r = UBound(a1) ' 999890 | 999890 | 999890
Debug.Print a1(1) & "-" & a1(r) & " | " & a2(1) & "-" & a2(r) & " | " & a3(1) & "-" & a3(r) ' 11•2-999900•2 | 11•4-999900•4 | 11•6-999900•6
End Sub
'==================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Что делает инструмент: фильтрует (оставляет) в переданном стринговом массиве только те элементы, чьи индексы есть в переданном массиве индексов (он отсортирован/собран по возрастанию индексов). Дополнительная опция позволяет инвертировать фильтр, то есть убрать элементы с переданными индексами.
Нужна процедура в библе на сях, позволяющая делать тоже самое, что и вариант ниже на VBA. Интересно будет сравнить скорость, т.к. у VBA она очень неплохая. Далее, можно будет сравнить пересбор одномерного вариативного массива и двумерного вариативного массива — отрыв должен быть заметнее.
Код
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub Arr1D_Filter_ByInd(a1D_Filt() As String, a1D_Ind() As Long, Optional Invert As Boolean)
Dim n&, nn&, i&
If Invert Then
i = 1
For nn = 1 To UBound(a1D_Filt)
If nn = a1D_Ind(i) Then
i = i + 1: If i > UBound(a1D_Ind) Then i = 1
Else
n = n + 1: a1D_Filt(n) = a1D_Filt(nn)
End If
Next nn
ReDim Preserve a1D_Filt(n)
Else
For n = 1 To UBound(a1D_Ind)
a1D_Filt(n) = a1D_Filt(a1D_Ind(n))
Next n
ReDim Preserve a1D_Filt(UBound(a1D_Ind))
End If
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_Arr1D_Filter_ByInd_Example()
Dim sF$(), s$(), i&(), n&
ReDim sF(10)
ReDim i(4)
For n = 1 To UBound(sF)
sF(n) = n
Next n
' Choose ONE
i(1) = 1: i(2) = 2: i(3) = 9: i(4) = 10 ' 1|2|9|10 + 3|4|5|6|7|8
i(1) = 2: i(2) = 4: i(3) = 6: i(4) = 8 ' 2|4|6|8 + 1|3|5|7|9|10
s = sF: Arr1D_Filter_ByInd s, i
Debug.Print Join(s, "|")
s = sF: Arr1D_Filter_ByInd s, i, True
Debug.Print Join(s, "|")
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_Arr1D_Filter_ByInd_Speed()
Dim sF$(), s$(), i&(), t!, n&, p&
t = Timer
ReDim sF(20000000) ' 20 mln
ReDim i(UBound(sF) / 2)
For n = 1 To UBound(sF)
sF(n) = n
If n Mod 2 Then p = p + 1: i(p) = n
Next n
Debug.Print Format$(Timer - t, "0.0"), "Create" ' 3.5
s = sF: t = Timer
Arr1D_Filter_ByInd s, i
Debug.Print Format$(Timer - t, "0.0"), "Filter", UBound(s) ' 1.3 | 10 mln
s = sF: t = Timer
Arr1D_Filter_ByInd s, i, True
Debug.Print Format$(Timer - t, "0.0"), "FilterInvert", UBound(s) ' 1.7 | 10 mln
End Sub
'==================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Реальная задача (из #9): …я планирую модифицировать свою форму с фильтром, сделав 3 поля: "начинается с", "содержит" и "заканчивается на". Также будет опция "инвертировать" — для каждого из полей и "перебор" — для центрального поля "содержит" (чтобы при вводе "стальной металлокаркас" находилось "металлокаркас стальной", например). Это очень удобно для пользователя. А, чтобы превратить подобные вводные в пригодную для твоего фильтра форму нужно написать отдельную функцию, что, на самом деле, проблемой не является, но, уверен, что отдельный инструмент под это будет заметно шустрее существующего комбайна.
Дополнение к описанию выше: Учитывая, что подстроки могут повторяться и входить друг в друга, единственное, найденное мной решение с помощью комбайна — это получить все возможные перестановки подстрок и передать их с параметром ИЛИ. Проблемы: • получить перестановки непросто — нужен генератор (у меня-то он есть, а другим как?) • на получение перестановок нужно время. Количество вариантов равно факториалу количества подстрок, что для 10ти подстрок уже равно почти 3,7 млн и само время их получения (не говоря о времени фильтрации) сведёт на нет всю мощь комбайна. • это противоречит самой логике комбайна. Это просто костыль, на который он не рассчитан. Например, если задано начало и конец, то в комбайне придётся каждую комбинацию подстрок сопровождать ими в виде "начало*комбинация*конец". Решение: У меня это решается сортировкой подстрок от наибольшей и удалением (заменой на символ 0) очередной найденной подстроки из строки поиска. При этом, количество операций равно количеству подстрок, а начало/конец проверяются ПЕРЕД подстроками и один раз для каждой строки массива. Мой инструмент гораздо удобнее применять (как минимум — в описанных условиях 3ёх полей ввода). Лучше всего для решения этой задачи — иметь такой же инструмент, но на сях.
End UPD
Зачем: фильтр-комбайн Виталия крайне сложен для использования (ввод условий), и (что более важно, т.к. ввод условий можно перехватить на VBA) крайне редко бывает необходим в таком виде. Возникла необходимость и сформировался конструктивный запрос на гораздо более упрощённый фильтр.
Что делает: • возвращает (изменяет переданный) Long-массив индексов, оставляя только те, что подходят. Пересбор по индексам очень быстрый (на сях — тем более), функция становится легче (не нужно заполнять массив значений, т.к. он может быть не нужен) и универсальнее (можно передать один массив, а по полученным индексам собирать значения из другого, такого же размера). • ищет переданный массив подстрок в каждой строке переданного массива. Массив может быть пустым, если переданы начало и/или конец (см. далее) • можно передать начало и/или конец отбираемых строк. Не зависит от массива переданных подстрок и типа поиска. • можно искать подстроки БЕЗ учёта порядка — NotOrder • можно искать строки НЕ СООТВЕТСТВУЮЩИЕ началу/концу/подстрокам — NotEqual • поиск (в моей интерпретации) осуществляется С УЧЁТОМ РЕГИСТРА, поскольку основное применение данного фильтра будет в форме поиска, а там у меня уже присутствуют различные варианты массивов на основе заданного (то есть, для реализации поиска без учёта регистра, например, я буду осуществлять поиск с учётом регистра в массиве, где все элементы уже преобразованы в нижний регистр).
Для теста используется генератор фраз из этой моей темы.
Основной код. Функция — вверху, тесты — внизу
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' a1D_Filt() As String: строковый массив значений для отбора
' a1D_SubStr() As String: строковый массив подстрок для отбора
' a1D_Ind_Ret() As Long: целочисленный массив с индексами отобранных элементов из a1D_Filt()
' [sBeg]: подстрока начала. Отбирать только строки, которые [не]начинаются с этой подстроки
' [sEnd]: подстрока окончания. Отбирать только строки, которые [не]заканчиваются этой подстрокой
' [NotEqual] As Boolean: НЕ РАВНО. Отбирать строки НЕ соответствующие подстрокам/началу/концу
' [NotOrder] As Boolean: Без учёта порядка. Искать каждую подстроку из массива с начала, а не после предыдущей. Не влияет на подстроки начала/конца.
'
Private Function Arr1D_Filter_GetInd(a1D_Filt() As String, a1D_SubStr() As String, a1D_Ind_Ret() As Long, Optional ByVal sBeg$, Optional ByVal sEnd$, Optional ByVal NotEqual As Boolean, Optional ByVal NotOrder As Boolean) As Boolean
Dim lb&, lE&, nF&, nS&, i&, n&, UBSS&
ReDim a1D_Ind_Ret(UBound(a1D_Filt))
lb = Len(sBeg): lE = Len(sEnd)
On Error Resume Next: UBSS = UBound(a1D_SubStr): On Error GoTo 0
For nF = 1 To UBound(a1D_Filt)
If lb <> 0 Then If ((Left$(a1D_Filt(nF), lb) = sBeg) = NotEqual) Then GoTo nx
If lE <> 0 Then If ((Right$(a1D_Filt(nF), lE) = sEnd) = NotEqual) Then GoTo nx
i = 1
For nS = 1 To UBSS
If NotOrder Then
If ((InStr(1, a1D_Filt(nF), a1D_SubStr(nS), vbBinaryCompare) = 0) <> NotEqual) Then GoTo nx
Else
i = InStr(i, a1D_Filt(nF), a1D_SubStr(nS), vbBinaryCompare)
If ((i = 0) <> NotEqual) Then GoTo nx Else i = i + Len(a1D_SubStr(nS))
End If
Next nS
n = n + 1: a1D_Ind_Ret(n) = nF
nx:
Next nF
If n <> 0 Then ReDim Preserve a1D_Ind_Ret(n): Arr1D_Filter_GetInd = True
End Function
'==================================================================================================
Private Sub Arr1D_Filter_ByInd(a1D_Filt() As String, a1D_Ind_Ret() As Long)
Dim n&
For n = 1 To UBound(a1D_Ind_Ret)
a1D_Filt(n) = a1D_Filt(a1D_Ind_Ret(n))
Next n
ReDim Preserve a1D_Filt(UBound(a1D_Ind_Ret))
End Sub
'==================================================================================================
'==================================================================================================
Private Function GetTestArray(aStr() As String) As Boolean
Dim x, a$(), n&
Dim NotOrder As Boolean, NotEqual As Boolean
x = Array("саша", "маша", "пётр", "осётр", "наташа", "натренирован", "иннокентий", "кентукки", "сорванец")
ReDim a(UBound(x))
For n = 1 To UBound(a)
a(n) = x(n)
Next n
GetTestArray = PRDX_Combine_Permutations_GetArr1D_AllVariants(a, aStr, "|") ' 1.0 | 986 409 variants
End Function
'==================================================================================================
'==================================================================================================
Private Sub ReBuild_1Col(aLoad(), aFilt() As String, aInd() As Long, Optional ByVal sHead$)
Dim n&
If Len(sHead) = 0 Then sHead = "Value"
ReDim aLoad(1 + UBound(aInd), 1)
aLoad(1, 1) = sHead
For n = 1 To UBound(aInd)
aLoad(n + 1, 1) = aFilt(aInd(n))
Next n
End Sub
'==================================================================================================
Private Sub ReBuild_2Col(aLoad(), aFilt() As String, aInd() As Long, Optional ByVal sHead$)
Dim n&
If Len(sHead) = 0 Then sHead = "Value"
ReDim aLoad(1 + UBound(aInd), 2)
aLoad(1, 1) = "Ind": aLoad(1, 2) = sHead
For n = 1 To UBound(aInd)
aLoad(n + 1, 1) = aInd(n)
aLoad(n + 1, 2) = aFilt(aInd(n))
Next n
End Sub
'==================================================================================================
Private Sub LoadOnSheet(aLoad())
Columns("A:B").ClearContents
[a1].Resize(UBound(aLoad, 1), UBound(aLoad, 2)).Value2 = aLoad
End Sub
'==================================================================================================
'==================================================================================================
Private Sub Test_Arr1D_Filter()
Dim a(), aFilt$(), aSub$(), aInd&(), sBeg$, sEnd$, t!, n&
Dim NotOrder As Boolean, NotEqual As Boolean
Dim MainArrFilt As Boolean, BegEnd As Boolean
t = Timer
If Not GetTestArray(aFilt) Then Debug.Print "Not Combined": Exit Sub
Debug.Print Format$(Timer - t, "0.0"), "Combine", UBound(aFilt)
NotEqual = 0
NotOrder = 0
MainArrFilt = 1
BegEnd = 1
If BegEnd Then
sBeg = "са"
sEnd = "кки"
End If
If MainArrFilt Then
ReDim aSub(4)
aSub(1) = "аша"
aSub(2) = "ётр"
aSub(3) = "нат"
aSub(4) = "кент"
End If
t = Timer
If Not Arr1D_Filter_GetInd(aFilt, aSub, aInd, sBeg, sEnd, NotEqual, NotOrder) Then Debug.Print "Not Filtered": Exit Sub
Debug.Print Format$(Timer - t, "0.0"), "Filter", UBound(aInd)
t = Timer
ReBuild_2Col a, aFilt, aInd
Debug.Print Format$(Timer - t, "0.0"), "ReBuild"
t = Timer
LoadOnSheet a
Debug.Print Format$(Timer - t, "0.0"), "Load"
End Sub
'==================================================================================================
Private Sub Test_Arr1D_Filter_Simple()
Dim a(), aFilt$(), aSub3$(), aSub5$(), aEmp$(), aInd&(), n&
n = 99999
ReDim aFilt(n)
For n = 1 To n
aFilt(n) = n
Next n
ReDim aSub3(3)
aSub3(1) = "2"
aSub3(2) = "4"
aSub3(3) = "6"
ReDim aSub5(5)
aSub5(1) = "1"
aSub5(2) = "2"
aSub5(3) = "3"
aSub5(4) = "4"
aSub5(5) = "5"
ActiveSheet.UsedRange.ClearContents
' Find One Value "12345".
If Arr1D_Filter_GetInd(aFilt, aSub5, aInd) Then Debug.Print UBound(aInd) Else Debug.Print "Not Filtered": Exit Sub
ReBuild_1Col a, aFilt, aInd, "Subs 5 Equal": [a1].Resize(UBound(a, 1), 1).Value2 = a
' Find 120 Values like "12345", "13245", "54321", "13524" …
If Arr1D_Filter_GetInd(aFilt, aSub5, aInd, , , , True) Then Debug.Print UBound(aInd) Else Debug.Print "Not Filtered": Exit Sub
ReBuild_1Col a, aFilt, aInd, "Subs 5 Equal": [b1].Resize(UBound(a, 1), 1).Value2 = a
' Find 3124 Values without "1", "2", "3", "4" and "5"
If Arr1D_Filter_GetInd(aFilt, aSub5, aInd, , , True) Then Debug.Print UBound(aInd) Else Debug.Print "Not Filtered": Exit Sub
ReBuild_1Col a, aFilt, aInd, "Subs 5 Not Equal": [c1].Resize(UBound(a, 1), 1).Value2 = a
' Find 11 Values: One "[88][99]" Value + 10 Values like "[88]#[99]"
If Arr1D_Filter_GetInd(aFilt, aEmp, aInd, "88", "99") Then Debug.Print UBound(aInd) Else Debug.Print "Not Filtered": Exit Sub
ReBuild_1Col a, aFilt, aInd, "Subs 5 Not Equal": [d1].Resize(UBound(a, 1), 1).Value2 = a
' Find One Value: "[8][246][9]"
If Arr1D_Filter_GetInd(aFilt, aSub3, aInd, "8", "9") Then Debug.Print UBound(aInd) Else Debug.Print "Not Filtered": Exit Sub
ReBuild_1Col a, aFilt, aInd, "Subs 5 Not Equal": [e1].Resize(UBound(a, 1), 1).Value2 = a
' Find 6 Values: "[8][246][9]", "[8][264][9]", "[8][426][9]"…
If Arr1D_Filter_GetInd(aFilt, aSub3, aInd, "8", "9", , True) Then Debug.Print UBound(aInd) Else Debug.Print "Not Filtered": Exit Sub
ReBuild_1Col a, aFilt, aInd, "Subs 5 Not Equal": [f1].Resize(UBound(a, 1), 1).Value2 = a
' Find 12004 Values which NOT begin by "8", NOT ended by "9" and NOT EXISTS "2", "4" and "6"
If Arr1D_Filter_GetInd(aFilt, aSub3, aInd, "8", "9", True, True) Then Debug.Print UBound(aInd) Else Debug.Print "Not Filtered": Exit Sub
ReBuild_1Col a, aFilt, aInd, "Subs 5 Not Equal": [g1].Resize(UBound(a, 1), 1).Value2 = a
End Sub
'==================================================================================================
Генератор строк из заданного списка
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_Combine_Factorial(ByVal n&) As Double ' n[1:170]
Static st&, f&, a() As Double
If st = 0 Then
st = 1: ReDim a(170)
For f = 1 To UBound(a)
a(f) = WorksheetFunction.Fact(f)
Next f
End If
PRDX_Combine_Factorial = a(n)
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_Factorial()
Dim t!, n&, f#
t = Timer
For n = 1 To 10000000 ' 10 mln
' f = WorksheetFunction.Fact(170) ' 19.14
' f = PRDX_Combine_Factorial(170) ' 00.90
Next n
Debug.Print Format$(Timer - t, "0.00"), f
End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Combine_PermutationsAll_Count(ByVal n&) As Double ' n[1:170]
Dim f#, p#, c&
If n = 1 Then PRDX_Combine_PermutationsAll_Count = 1: Exit Function
If n = 2 Then PRDX_Combine_PermutationsAll_Count = 4: Exit Function
f = PRDX_Combine_Factorial(n)
For c = 1 To n - 2
p = p + (f / PRDX_Combine_Factorial(n - c))
Next c
PRDX_Combine_PermutationsAll_Count = p + (2 * f)
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PermutationsAll_Count()
Dim p#, t!, n&
t = Timer
For n = 1 To 100000 ' 100k
p = PRDX_Combine_PermutationsAll_Count(170) ' 1.8
Next n
Debug.Print Format$(Timer - t, "0.0"), p
End Sub
'--------------------------------------------------------------------------------------------------
Function PRDX_Combine_PermutationsAll_Count_Static(ByVal n&) As Double ' n[1:170]
Static st&, c&, a() As Double
If st = 0 Then
st = 1: ReDim a(170)
For c = 1 To UBound(a)
a(c) = PRDX_Combine_PermutationsAll_Count(c)
Next c
End If
PRDX_Combine_PermutationsAll_Count_Static = a(n)
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
' https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=151642&TITLE_SEO=151642-kombinatorika.-metod-perestanovok.-poluchit-vse-perestanovki-elementov-odnomernogo-massiva
Private Function NextPerm(a() As Long, n&) As Boolean 'Next Permutation by lexicographical order
Dim i&, k&, t&, tmp&
For k = n - 1 To 1 Step -1
If a(k) < a(k + 1) Then Exit For
Next k
If k Then
For i = n To k + 1 Step -1
If a(k) < a(i) Then tmp = a(k): a(k) = a(i): a(i) = tmp: Exit For
Next i
NextPerm = True
End If
t = n
For i = k + 1 To (n + k) \ 2
tmp = a(i): a(i) = a(t): a(t) = tmp: t = t - 1
Next i
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_Combine_Permutations_GetArr1D(aElem() As String, aJoin_Accum() As String, Optional nJoinPrev&, Optional ByVal sep$ = ", ") As Boolean
Dim aTmp$(), aInd&()
Dim i&, nF&
If LBound(aElem) <> 1 Then Stop: End
If UBound(aElem) < 2 Then Stop: End
If UBound(aElem) = 2 Then
If nJoinPrev = 0 Then ReDim aJoin_Accum(2)
nJoinPrev = nJoinPrev + 1: aJoin_Accum(nJoinPrev) = Join(aElem, sep)
nJoinPrev = nJoinPrev + 1: aJoin_Accum(nJoinPrev) = aElem(2) & (sep & aElem(1))
GoTo fin
End If
If UBound(aElem) > 10 Then Stop: End ' 11 is ~49 sec
nF = WorksheetFunction.Fact(UBound(aElem))
If nJoinPrev = 0 Then ReDim aJoin_Accum(nF)
ReDim aInd(nF): ReDim aTmp(UBound(aElem))
For i = 1 To UBound(aElem)
aInd(i) = i
Next i
Do
For i = 1 To UBound(aElem)
aTmp(i) = aElem(aInd(i))
Next i
nJoinPrev = nJoinPrev + 1: aJoin_Accum(nJoinPrev) = Join(aTmp, sep)
Loop While NextPerm(aInd(), UBound(aElem))
fin: PRDX_Combine_Permutations_GetArr1D = True
End Function
'==================================================================================================
'==================================================================================================
Sub PRDX_Combine_GetBin_Values(a() As LongLong, ByVal nVals&) ' nVals[1:19]
Dim m^, p&, n&, nA&
ReDim a((2 ^ nVals) - 1)
a(1) = 1: nA = 1
For p = 1 To nVals - 1
m = 10 ^ p
nA = nA + 1: a(nA) = m
For n = 1 To nA - 1
nA = nA + 1: a(nA) = m + a(n)
Next n
Next p
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_GetBin_Values()
Dim a^(), t!, n&
t = Timer
PRDX_Combine_GetBin_Values a, 19
Debug.Print Format$(Timer - t, "0.00"), UBound(a) ' 0.01
For n = 1 To 10
Debug.Print "a(" & n & ") = " & a(n)
Next n
End Sub
'==================================================================================================
Private Sub NumToArrL(ByVal nBin^, aL_ReDim() As Long) ' nLen[1:17]
Dim m^, p^, n&, nn&, nLen&, UB&
UB = UBound(aL_ReDim)
nLen = Len(CStr(nBin))
If UB < nLen Then Stop: End
m = 10 ^ nLen
For n = nLen To 1 Step -1
p = nBin \ m
If p <> 0 Then nn = nn + 1: aL_ReDim(nn) = UB - n: nBin = nBin - m
m = m / 10
Next n
If nBin <> 0 Then nn = nn + 1: aL_ReDim(nn) = UB
ReDim Preserve aL_ReDim(nn)
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_NumToArrL()
Dim a&(), t!, n&, v^, l
v = 1011101101# ' 10 sym
'v = 101
l = Len(CStr(v))
t = Timer
For n = 1 To 1000000 ' 1 mln
ReDim a(15)
NumToArrL v, a
Next n
Debug.Print Format$(Timer - t, "0.0"), l ' 0.8
For n = 1 To UBound(a)
Debug.Print n, a(n)
Next n
End Sub
'==================================================================================================
Sub PRDX_Combine_GetBin_ArrArrsL(aArrs(), nVals&) ' nVals[1:18]
Dim aB^(), aL&(), n&
PRDX_Combine_GetBin_Values aB, nVals
ReDim aArrs(UBound(aB))
For n = 1 To UBound(aB)
ReDim aL(nVals): NumToArrL aB(n), aL: aArrs(n) = aL
Next n
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_GetBin_ArrArrsL()
Dim aV(), aL&(), t!, n&, l&
t = Timer
PRDX_Combine_GetBin_ArrArrsL aV, 10
Debug.Print Format$(Timer - t, "0.0"), UBound(aV)
For n = 1 To 10
Debug.Print "Step: " & n, String$(50, "=")
aL = aV(n)
For l = 1 To UBound(aL)
Debug.Print "aL(" & l & ") = " & aL(l)
Next l
Next n
End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Combine_Permutations_GetArr1D_AllVariants(aElem() As String, aJoin() As String, Optional ByVal sep$ = ", ") As Boolean
Dim aV(), aStr$(), aL&(), n&, l&, j&, UB&
If LBound(aElem) <> 1 Then Stop: End
If UBound(aElem) < 2 Then Stop: End
If UBound(aElem) = 2 Then
ReDim aJoin(4)
aJoin(1) = aElem(1)
aJoin(2) = Join(aElem, sep)
aJoin(3) = aElem(2)
aJoin(4) = aElem(2) & (sep & aElem(1))
GoTo fin
End If
ReDim aJoin(PRDX_Combine_PermutationsAll_Count(UBound(aElem)))
PRDX_Combine_GetBin_ArrArrsL aV, UBound(aElem)
For n = 1 To UBound(aV)
aL = aV(n): UB = UBound(aL)
If UB = 1 Then
j = j + 1: aJoin(j) = aElem(aL(1))
Else
ReDim aStr(UB)
For l = 1 To UB
aStr(l) = aElem(aL(l))
Next l
If Not PRDX_Combine_Permutations_GetArr1D(aStr, aJoin, j, sep) Then Exit Function
End If
Next n
fin: PRDX_Combine_Permutations_GetArr1D_AllVariants = True
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_Permutations_GetArr1D_AllVariants()
Dim a$(), b$()
ReDim a(4)
a(1) = "маша"
a(2) = "петя"
a(3) = "даша"
a(4) = "вася"
If Not PRDX_Combine_Permutations_GetArr1D_AllVariants(a, b) Then Exit Sub
Debug.Print Join(b, vbLf)
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Сочинил процедуру для быстрого получения всех бинарных (состоящих только из цифр 0 и 1) чисел до заданной длины числа. В примере получаю все значения до 10ти знаков включительно. Количество чисел = (2 ^ 10) - 1 = 1023. Выполняется мгновенно.
Код
Код
Sub GetBin(a() As Double)
Dim p&, m#, n&, nA&
Const lvl& = 10
ReDim a(1 To (2 ^ lvl) - 1)
a(1) = 1: nA = 1
For p = 1 To lvl - 1
m = 10 ^ p
nA = nA + 1: a(nA) = m
For n = 1 To nA - 1
nA = nA + 1: a(nA) = m + a(n)
Next n
Next p
End Sub
'==================================================================================================
Private Sub Test_GetBin()
Dim a#(), t!
t = Timer
GetBin a
Debug.Print Format$(Timer - t, "0.00") ' 0.00
End Sub
Скорость меня устраивает, в цикле такое запускаться не будет (а, если будет, то есть статичные массивы), но, возможно, я что-то упустил или сделал не совсем оптимально. Прошу дать обратную связь.
UPD 25/05/2023: Стринговый комбайн. Решил не делать новую тему, т.к. очень похожая задача. Теперь нужно получить практически то же самое, но с ведущими нулями и, как следствие, в стринговый массив. Вопрос тот же — как ускорить?
Ряд для длины 3
Код с таймингом в тесте
Код
Option Base 1
Option Explicit
'==================================================================================================
Sub PRDX_Combine_GetBin_ArrS(a() As String, nLen&) ' nLen: [2 : 23] = [6 : 16 777 214]
Dim l&, n&, nS&, nE&, nn&
If nLen < 2 Or nLen > 23 Then Stop: End
ReDim a((2 ^ (nLen + 1)) - 2)
nS = 1
n = n + 1: a(n) = "0"
n = n + 1: a(n) = "1"
nE = n
For l = 2 To nLen
For nn = nS To nE
n = n + 1: a(n) = "0" & a(nn)
n = n + 1: a(n) = "1" & a(nn)
Next nn
nS = nE + 1: nE = n
Next l
End Sub
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Combine_GetBin_ArrS()
Dim a$(), t!
t = Timer
PRDX_Combine_GetBin_ArrS a, 23
Debug.Print Format$(Timer - t, "0.0"), Format$(UBound(a), "#,#") ' 3,2 | 16 777 214
End Sub
'==================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
С недавних пор решил бороться с некорректным использованием термина "макрос". Начал с себя, а потом и в общении с заказчиками стал пояснять важную разницу. Итак, по определению, но своими словами: макрос (правильно говорить "макрокоманда") [здесь и далее будут подразумеваться макрокоманды в продуктах MS Office и подобные им] — это записанная последовательность действий пользователя. Из этого следует, что макросы пишет сама программа/приложение и никто другой. В MS Excel этим занимается специальная программа, которая так и называется — макрорекордер (MacroRecorder — "макрописец"). Никто другой и ничто другое макросы не пишет. Чисто технически, программист, конечно, может написать альтернативную программу, которая подключается к приложению (MS Excel, например) и "переводит" действия пользователя в программный код, но, как мы все тут понимаем, разговор, не об этом.
Вывод: программисты пишут программы, некоторые из которых пишут макрокоманды
Альтернативные термины (вместо "напишите мне макрос", говорим … ): • напишите мне код на VBA • напишите мне скрипт (не совсем корректно, но вполне допустимо) на VBA • создайте/напишите мне программу на VBA • автоматизируйте мне следующие процессы с помощью VBA
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Нужен аналог (более-менее похожий) для управления проектами типа https://www.scrumwise.com/ - желательно, бесплатный и точно официальный (не кряк), для использования в компании. Данное ПО должно относится к категории "Scrum/Kanban-board", быть бесплатным, иметь WEB-версию и поддерживать совместную работу. Пока изучаю этот перечень.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
В сцене из фильма аудитории на лекции задаётся вопрос (произвольная трактовка): если перед вами 3 двери, за одной из которых приз, вы выбрали одну из них, я открыл другую, за которой приза нет, то будете ли вы менять свой выбор? Проверяемое утверждение гласит, что стоит менять выбор двери при открытии очередной пустой — это математически обоснованно.
Я сделал версию для любого количества дверей, а тестировал (и сделал скрины результатов) на 10, 100 и 1000 дверей. Мой код также подтвердил, что менять выбор — лучше. Прошу посмотреть код на предмет корректности.
Код Игоря из файла
Код
Option Explicit
Sub Simulator()
Randomize: Columns(7).ClearContents
Dim r&, rc&, a(), i&, j&, m&, p&, v&, b&, c&, rez&()
For j = 1 To 35
ReDim rez(1 To 3): rc = 1000: ReDim a(1 To rc, 1 To 6)
For r = 1 To rc
m = 1
For i = 1 To 3
a(r, i) = Rnd: If a(r, i) > a(r, m) Then m = i
Next
a(r, m) = m: b = 14: b = b And Not 2 ^ m
a(r, 4) = Int(1 + 3 * Rnd): b = b And Not 2 ^ a(r, 4)
If a(r, 4) <> m Then
For i = 1 To 3
If b = 2 ^ i Then Exit For
Next
a(r, 5) = i: rez(3) = rez(3) + 1
Else
p = Int(1 + Rnd * 2): c = 0: rez(1) = rez(1) + 1
For i = 1 To 3
If i <> m Then c = c + 1
If c = p Then a(r, 5) = i: Exit For
Next
End If
For i = 1 To 3
If i <> a(r, 4) And i <> a(r, 5) Then a(r, 6) = i: Exit For
Next
Next
Cells(j, 7) = rez(1)
Next
Cells(3, 1).Resize(rc, 6) = a: Cells(1, 4).Resize(1, 3) = rez
End Sub
Мои скрины и Код
Скрины результатов для 10, 100 и 1000 дверей
Код
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Function GetRnd(lMin&, lMax&) As Long
Randomize
GetRnd = Int((lMax - lMin + 1) * Rnd + lMin)
End Function
'==================================================================================================
' Изменяет lTry на количество попыток
' Возвращает номер очередной выбранной двери и добавляет её в словарь
Private Function ChooseNextDoor(lMin&, lMax&, dic As Dictionary, Optional lTry&) As Long
lTry = 0
Do
lTry = lTry + 1
ChooseNextDoor = GetRnd(lMin, lMax)
If Not dic.Exists(ChooseNextDoor) Then Exit Function
Loop
End Function
'==================================================================================================
'==================================================================================================
' Возвращает количество попыток, пройденных для нахождения искомого lPrize (статичный выбор)
Function PlayerStatic(lPrize&, lMin&, lMax&) As Long
Dim dicOpen As New Dictionary
Dim lDelta&, lChoose&, lOpen&
lDelta = lMax - lMin + 1 ' количество "дверей" в списке
If lDelta < 3 Then Stop: End
lChoose = GetRnd(lMin, lMax) ' ВЫБИРАЕМ дверь (один раз)
Do
PlayerStatic = PlayerStatic + 1 ' считаем попытки
If lChoose = lPrize Then Exit Function ' если ВЫБРАЛИ на призовую, то выходим
lOpen = ChooseNextDoor(lMin, lMax, dicOpen) ' ОТКРЫВАЕМ очередную дверь (НЕоткрытую ранее)
If lOpen = lPrize Then Exit Function ' если ОТКРЫЛИ призовую, то выходим
dicOpen.add lOpen, 0 ' ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей очередную ОТКРЫТУЮ дверь
If dicOpen.Count = lDelta - 1 Then ' если открыты все, кроме одной, то ОТКРЫВАТЬ не из чего (следующим шагом гарантированно будет ОТКРЫТА ПРИЗОВАЯ дверь)
PlayerStatic = PlayerStatic + 1
Exit Function
End If
Loop
End Function
'--------------------------------------------------------------------------------------------------
' Возвращает количество попыток, пройденных для нахождения искомого lPrize (постоянная смена выбора)
Function PlayerChange(lPrize&, lMin&, lMax&) As Long
Dim dicChoose As New Dictionary, dicOpen As New Dictionary
Dim lDelta&, lChoose&, lOpen&, fAllChosen As Boolean
lDelta = lMax - lMin + 1 ' количество "дверей" в списке
If lDelta < 3 Then Stop: End
dicOpen.add lPrize, 0 ' ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей ПРИЗОВУЮ дверь, чтобы не открыть
Do
PlayerChange = PlayerChange + 1 ' считаем попытки
If fAllChosen Then ' если все двери уже были выбраны …
dicOpen.Remove lPrize ' … УДАЛЯЕМ из словаря ОТКРЫТЫХ дверей ПРИЗОВУЮ, чтобы она участвовала в ВЫБОРЕ
lChoose = ChooseNextDoor(lMin, lMax, dicOpen) ' … ВЫБИРАЕМ очередную дверь с учётом открытых
dicOpen.add lPrize, 0 ' … ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей ПРИЗОВУЮ
Else ' в противном случае …
lChoose = ChooseNextDoor(lMin, lMax, dicChoose) ' … ВЫБИРАЕМ очередную дверь с учётом ВЫБРАННЫХ и ОТКРЫТЫХ дверей ранее
End If
If lChoose = lPrize Then Exit Function ' если попали на призовую, то выходим
dicChoose.add lChoose, 0 ' ДОБАВЛЯЕМ в словарь ВЫБРАННЫХ дверей очередную ВЫБРАННУЮ дверь
dicOpen.add lChoose, 0 ' ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей очередную ВЫБРАННУЮ дверь, чтобы не открыть её
lOpen = ChooseNextDoor(lMin, lMax, dicOpen) ' ОТКРЫВАЕМ очередную дверь (НЕпризовую, НЕоткрытую ранее и не выбранную)
dicOpen.Remove lChoose ' УДАЛЯЕМ из словаря ОТКРЫТЫХ дверей очередную ВЫБРАННУЮ дверь
dicOpen.add lOpen, 0 ' ДОБАВЛЯЕМ в словарь ОТКРЫТЫХ дверей очередную ОТКРЫТУЮ дверь
If dicOpen.Count = lDelta - 1 Then ' если открыты все, кроме одной, то ВЫБИРАТЬ не из чего (следующим шагом гарантированно будет ВЫБРАНА ПРИЗОВАЯ дверь)
PlayerChange = PlayerChange + 1
Exit Function
End If
If dicChoose.Count = lDelta Then ' если словарь выбранных дверей содержит все двери …
fAllChosen = True ' … ставим флаг
dicChoose.RemoveAll ' … очищаем словарь
End If
If Not fAllChosen Then
If Not dicChoose.Exists(lOpen) Then dicChoose.add lOpen, 0 ' ДОБАВЛЯЕМ в словарь ВЫБРАННЫХ дверей очередную ОТКРЫТУЮ дверь (если ещё не все двери были выбраны)
End If
Loop
End Function
'==================================================================================================
'==================================================================================================
Sub TestPlay()
Dim t!, l&, lPrize&, lTry&
Dim lStMin&, lStMax&, lStTot&
Dim lChMin&, lChMax&, lChTot&
Const lMin& = 1, lMax& = 10, lCyc& = 10000
lStMin = lMax
lChMin = lMax
t = Timer
For l = 1 To lCyc
lPrize = GetRnd(lMin, lMax) ' номер двери с призом
lTry = PlayerStatic(lPrize, lMin, lMax)
lStTot = lStTot + lTry
If lStMin > lTry Then lStMin = lTry
If lStMax < lTry Then lStMax = lTry
lTry = PlayerChange(lPrize, lMin, lMax)
lChTot = lChTot + lTry
If lChMin > lTry Then lChMin = lTry
If lChMax < lTry Then lChMax = lTry
Next l
Debug.Print Format$(Timer - t, "0.00")
Debug.Print "Min", "Av", "Max", "Tot"
Debug.Print "St"
Debug.Print Format$(lStMin, "#,##0"), Format$(lStTot / lCyc, "#,##0.0"), Format$(lStMax, "#,##0"), Format$(lStTot, "#,##0")
Debug.Print "Ch"
Debug.Print Format$(lChMin, "#,##0"), Format$(lChTot / lCyc, "#,##0.0"), Format$(lChMax, "#,##0"), Format$(lChTot, "#,##0")
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Основная ветка. Думаю, имеет смысл переименовать основную ветку "Вопросы по Microsoft Excel" в "Вопросы по Microsoft Excel для Windows", поскольку не все дойдут глазами до ветки по маку и поймут, что в основную об этом лучше не писать… Навеяно
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Тема родилась после изучения ссылки из этой темы. Файлы хранятся на Кибере из-за ограничений Планеты и нецелесообразности хранить подобные справочные материалы на файлообменниках.
Вопросы: • Как использовать программу MyStem в VBA? • Какие другие библиотеки можно использовать? • Можно ли и как перенести алгоритм в VBA, чтобы не зависеть от библиотек? Можно, конечно, "вшить" библу в файл, но чистый алгоритм был бы очень интересен.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Функция нужна для отчётов: Debug.Print, MsgBox или печать лога в текстовый файл, но "чтоб как таблица было".
Скрин
Код
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_Arr2D_To1D_AlignmentStrings(a2D, Optional ByVal nSpaces& = 1) As String()
Dim aStr$(), aLen&(), aSps$()
Dim tx$, r&, c&, l&
ReDim aStr(UBound(a2D, 1))
ReDim aLen(UBound(a2D, 2))
For r = 1 To UBound(a2D, 1)
For c = 1 To UBound(a2D, 2)
a2D(r, c) = Trim$(a2D(r, c))
l = Len(a2D(r, c))
If l > aLen(c) Then aLen(c) = l
Next c
Next r
ReDim aSps(UBound(aLen))
For c = 1 To UBound(aLen)
aSps(c) = Space$(aLen(c) + nSpaces)
Next c
For r = 1 To UBound(a2D, 1)
For c = 1 To UBound(a2D, 2)
tx = aSps(c)
Mid$(tx, 1, Len(a2D(r, c))) = a2D(r, c)
aStr(r) = aStr(r) & tx
Next c
aStr(r) = Trim$(aStr(r))
Next r
PRDX_Arr2D_To1D_AlignmentStrings = aStr
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_Arr2D_To1D_AlignmentStrings()
Dim x
ReDim x(3, 3)
x(1, 1) = "My dream": x(1, 2) = "is": x(1, 3) = "to fly"
x(2, 1) = "Over": x(2, 2) = "the": x(2, 3) = "rainbow"
x(3, 1) = "So": x(3, 2) = "": x(3, 3) = "high"
Debug.Print Join(PRDX_Arr2D_To1D_AlignmentStrings(x, 3), vbLf)
End Sub
UPD 26/01/2023:
Описание обновления
• Ускорил в 4 раза. • Теперь можно использовать в качестве разделителя элементов любой символ или даже строку. До общей длины по столбцу элементы по прежнему "добиваются" пробелами. Можно и это сделать переменной, но практического смысла пока не вижу. • Теперь функция возвращает длину [каждой] строки сцепки, а строковый массив для заполнения, нужно передать.
Скрин
Код
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_Arr2D_To1D_AlignmentStrings(a2D, a1D_Res$(), Optional ByVal sepJoin$ = " ") As Long
Dim aLen&(), tx$, txSp$, r&, c&, l&, lSep&
ReDim a1D_Res(UBound(a2D, 1))
ReDim aLen(UBound(a2D, 2))
For c = 1 To UBound(a2D, 2)
For r = 1 To UBound(a2D, 1)
l = Len(a2D(r, c))
If l > aLen(c) Then aLen(c) = l
Next r
Next c
l = 0
For c = 1 To UBound(aLen)
l = l + aLen(c)
Next c
lSep = Len(sepJoin)
l = l + lSep * (UBound(aLen) - 1)
PRDX_Arr2D_To1D_AlignmentStrings = l
txSp = Space$(l): l = 0
For r = 1 To UBound(a2D, 1)
tx = txSp
For c = 1 To UBound(a2D, 2) - 1
Mid$(tx, l + 1, aLen(c)) = a2D(r, c): l = l + aLen(c)
Mid$(tx, l + 1, lSep) = sepJoin: l = l + lSep
Next c
Mid$(tx, l + 1, aLen(c)) = a2D(r, c)
a1D_Res(r) = tx: l = 0
Next r
End Function
'--------------------------------------------------------------------------------------------------
Private Sub TestSpeed_PRDX_Arr2D_To1D_AlignmentStrings()
Dim bef$(), aft$()
Dim t!, n&, l&
Const nCyc& = 1000000
ReDim bef(3, 3)
bef(1, 1) = "My dream": bef(1, 2) = "is": bef(1, 3) = "to fly"
bef(2, 1) = "Over": bef(2, 2) = "the": bef(2, 3) = "rainbow"
bef(3, 1) = "So": bef(3, 2) = "": bef(3, 3) = "high"
t = Timer
For n = 1 To nCyc
l = PRDX_Arr2D_To1D_AlignmentStrings(bef, aft, " — ") ' 3.23
Next n
Debug.Print Format$(Timer - t, "0.00"), l
Debug.Print Join(aft, vbLf)
End Sub
Ускорил в 4 раза и добавил возможность выбора разделителя. Последние версии всех решений — в блоге. Здесь шапку не всегда смогу обновлять (сейчас обновил).
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Здесь обсуждаются предложения к Правилам платной ветки.
Добавить пункт: "В теме ведётся только поиск исполнителя: "пишу в личку / в работе / обменялись / отказ". В противном случае, заказ превратится в свалку. Может быть уместно небольшое описание нюансов ТЗ со стороны отказавшегося исполнителя, чтобы другие имели это в виду. Запрещается предлагать и обсуждать варианты решения вопроса или вести какие-либо другие беседы. Обсуждения ведутся в основной ветке по конкретным вопросам."
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Новая запись в блоге на Кибере. Дублирую. Все обновления данной темы (как и всех других тем-ссылок на блог) будут там.
Приветствую! Решил выложить свои (и не только) решения по осуществлению задачи по замене слов в строке. Вопрос был поднят на Планете, откуда я и взял шаблон для регулярки, созданный Игорем Гончаренко.
Начать нужно с того, что считать [отдельным] "словом": в предложенных решениях "словом" считается 1 и более [идущих подряд] символов кириллицы или латиницы.
Предложены 2 различных подхода: регулярные выражения и комплексный алгоритм на основе парсинга строки, как байтового массива. Для каждого из вариантов есть 2 версии: для замены одного "слова" и для замены "слов" по списку.
Все функции оптимизированы и очень быстрые, а также имеют опцию игнорирования регистра. Базовые необходимые проверки присутствуют. Регулярные функции являются булевыми, а мои — возвращают количество произведённых замен.
Регулярные выражения - чрезвычайно мощный инструмент (не забываем про раннее связывание), соревноваться с которым на VBA очень тяжело. Мне удалось приблизиться к его скорости, а в некоторых тестах даже сравняться или незначительно обогнать.
«Main». Основной модуль с тестовой процедурой и функциями замены
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function TextMult(ByVal v$, Mult&, Optional ByVal Sep$ = " ") As String
Dim tx$, n&
For n = 1 To Mult
tx = tx & Sep & v
Next n
TextMult = Mid$(tx, Len(Sep) + 1)
End Function
'==================================================================================================
Private Sub Test()
Dim aFnd, aRpl
Dim tx$, res$, t!, n&, nR&
Const nCyc& = 100000, nMult& = 10 ' nMult=1 Для проверки исходной строки
tx = "Вася вас не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»"
aFnd = Array("вас", "пет", "alex")
aRpl = Array("Василий Семёнович", "Пётр Петрович", "Jack")
' Раскомментировать, если нужно проверить
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord(res, "вас", "Василий Семёнович"), res ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord(res, "пет", "Пётр Петрович", True), res ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl), res ' 3 | Вася Василий Семёнович не Вас,Петя:Пётр Петрович;не,Пет,Alexey-Jack*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl, True), res ' 6 | Вася Василий Семёнович не Василий Семёнович,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-Jack*not«Jack»
' Число замен рассчитано с помощью RE.Execute().Count. Считает некорректно. Убрал. Если оставить, то увеличивает время выполнения примерно в 2 раза.
'res = tx: Debug.Print IG_ReplaceWholeWord(res, "вас", "Василий Семёнович"), res ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord(res, "пет", "Пётр Петрович", True), res ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord_Array(res, aFnd, aRpl), res ' 1 | Вася Василий Семёнович не Вас,Петя:Пётр Петрович;не,Пет,Alexey-Jack*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord_Array(res, aFnd, aRpl, True), res ' 2 | Вася Василий Семёнович не Василий Семёнович,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-Jack*not«Jack»
tx = TextMult(tx, nMult)
t = Timer ' Исх. | x10
For n = 1 To nCyc / nMult
res = tx: nR = PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl) ' 2.58 | 1.78
' res = tx: nR = PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl, True) ' 2.89 | 1.97
' res = tx: nR = IG_ReplaceWholeWord_Array(res, aFnd, aRpl) ' 2.64 | 1,48
' res = tx: nR = IG_ReplaceWholeWord_Array(res, aFnd, aRpl, True) ' 2,98 | 1.66
Next n
Debug.Print Format$(Timer - t, "0.00"), nR
End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Text_Replace_WholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim n&, nRpl&
If Not LCase$(tmpString) Like "*[a-zёа-я]*" Then Exit Function
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
iFnd = LCase$(iFnd)
For n = 1 To UBound(aWrd)
If iFnd = LCase$(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = iRpl
Next n
Else
For n = 1 To UBound(aWrd)
If iFnd = aWrd(n) Then nRpl = nRpl + 1: aWrd(n) = iRpl
Next n
End If
If nRpl Then PRDX_Text_Replace_WholeWord = nRpl Else Exit Function
tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep)
End Function
'==================================================================================================
Function PRDX_Text_Replace_WholeWord_Array(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim tx$, f&, n&, nRpl&
Static st&, dic As Dictionary
If Not LCase$(tmpString) Like "*[a-zёа-я]*" Then Exit Function
If st = 0 Then st = 1: Set dic = New Dictionary
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
For n = LBound(aFind) To UBound(aFind)
tx = LCase$(aFind(n))
If Not dic.Exists(tx) Then dic.Add tx, aRpl(n)
Next n
For n = 1 To UBound(aWrd)
tx = LCase$(aWrd(n))
If dic.Exists(tx) Then nRpl = nRpl + 1: aWrd(n) = dic(tx)
Next n
Else
For n = LBound(aFind) To UBound(aFind)
tx = aFind(n)
If Not dic.Exists(tx) Then dic.Add tx, aRpl(n)
Next n
For n = 1 To UBound(aWrd)
If dic.Exists(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = dic(aWrd(n))
Next n
End If
dic.RemoveAll
If nRpl Then PRDX_Text_Replace_WholeWord_Array = nRpl Else Exit Function
tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep)
End Function
'==================================================================================================
'==================================================================================================
Function IG_ReplaceWholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Boolean
Dim x, tx$
Static st&, RE As RegExp, REci As RegExp
If st = 0 Then
st = 1
Set RE = New RegExp: RE.Global = True
Set REci = New RegExp: REci.Global = True: REci.IgnoreCase = True
End If
If CaseIgnore Then
tx = "(^|[^a-zа-яё])" & iFnd & "(?=[^a-zа-яё]|$)"
If REci.Pattern <> tx Then REci.Pattern = tx
If REci.Test(tmpString) Then IG_ReplaceWholeWord = True Else Exit Function
tmpString = REci.Replace(tmpString, "$1" & iRpl)
Else
tx = "(^|[^A-Za-zА-яЁё])" & iFnd & "(?=[^A-Za-zА-яЁё]|$)"
If RE.Pattern <> tx Then RE.Pattern = tx
If RE.Test(tmpString) Then IG_ReplaceWholeWord = True Else Exit Function
tmpString = RE.Replace(tmpString, "$1" & iRpl)
End If
End Function
'==================================================================================================
Function IG_ReplaceWholeWord_Array(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean) As Boolean
Dim x, n&
Static st&, RE As RegExp, REci As RegExp
If st = 0 Then
st = 1
Set RE = New RegExp: RE.Global = True
Set REci = New RegExp: REci.Global = True: REci.IgnoreCase = True
End If
If CaseIgnore Then
For n = LBound(aFind) To UBound(aFind)
REci.Pattern = "(^|[^a-zа-яё])" & aFind(n) & "(?=[^a-zа-яё]|$)"
If REci.Test(tmpString) Then IG_ReplaceWholeWord_Array = True Else Exit Function
tmpString = REci.Replace(tmpString, "$1" & aRpl(n))
Next n
Else
For n = LBound(aFind) To UBound(aFind)
RE.Pattern = "(^|[^A-Za-zА-яЁё])" & aFind(n) & "(?=[^A-Za-zА-яЁё]|$)"
If RE.Test(tmpString) Then IG_ReplaceWholeWord_Array = True Else Exit Function
tmpString = RE.Replace(tmpString, "$1" & aRpl(n))
Next n
End If
End Function
Модуль «AscW_Check». Функция определения принадлежности символа по его коду AscW к кириллице или латинице
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Num: 48-57
' Lat: 65-90; 97-122
' Cyr: 1025; 1040-1103; 1105
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function PRDX_AscW_CyrAndLat_GetArr() As Long()
Dim a&(1105), s&
For s = 65 To 1105
Select Case s
Case 91: s = 97
Case 123: s = 1025
Case 1026: s = 1040
Case 1104: s = 1105
End Select
a(s) = 1
Next s
PRDX_AscW_CyrAndLat_GetArr = a
End Function
'==================================================================================================
Function PRDX_AscW_CyrAndLat_Is(iAscW&) As Boolean
Static st&, a&()
If iAscW > 1105 Then Exit Function
If st = 0 Then st = 1: a = PRDX_AscW_CyrAndLat_GetArr()
If a(iAscW) Then PRDX_AscW_CyrAndLat_Is = True
End Function
Модуль «Splitter». Получение из строки 2ух массивов: слова и неслова
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub Test_PRDX_SplitString_ByNonCyrLat()
Dim x, w$(), s$(), n&
x = ",./asd.gh./*красота/*b./7jg,,./"
If Not PRDX_SplitString_ByNonCyrLat(x, w, s) Then Exit Sub
For n = 1 To UBound(s)
Debug.Print "«" & s(n) & "»"
If n < UBound(s) Then Debug.Print "«" & w(n) & "»"
Next n
Debug.Print x = PRDX_SplitString_ByNonCyrLat_Join(w, s)
End Sub
'==================================================================================================
'==================================================================================================
' Fill aWrd(N) and aSep(N+1)
Function PRDX_SplitString_ByNonCyrLat(ByVal iStr$, aWrd$(), aSep$()) As Boolean
Dim aBt() As Byte
Dim i&, n&, nW&, nS&, bW&, bS&
aBt = iStr
ReDim aWrd(Len(iStr))
ReDim aSep(UBound(aWrd))
For i = 0 To UBound(aBt) Step 2
n = n + 1
If PRDX_AscW_CyrAndLat_Is(aBt(i) + 256 * aBt(i + 1)) Then ' Ltr
If bW Then GoTo nx Else bW = n
If bS = 0 Then
If nS = 0 Then nS = nS + 1: aSep(nS) = ""
GoTo nx
End If
nS = nS + 1: aSep(nS) = Mid$(iStr, bS, n - bS): bS = 0
Else ' NonLtr
If bS Then GoTo nx Else bS = n
If bW = 0 Then GoTo nx
nW = nW + 1: aWrd(nW) = Mid$(iStr, bW, n - bW): bW = 0
End If
nx:
Next i
If bW Then
nW = nW + 1: aWrd(nW) = Mid$(iStr, bW)
Else
nS = nS + 1: aSep(nS) = Mid$(iStr, bS)
End If
If nW = 0 Then Stop: End
If nS < nW Then Stop: End
If nS > nW + 1 Then Stop: End
If nS = nW Then nS = nS + 1: aSep(nS) = ""
ReDim Preserve aWrd(nW)
ReDim Preserve aSep(nS)
PRDX_SplitString_ByNonCyrLat = True
End Function
'==================================================================================================
Function PRDX_SplitString_ByNonCyrLat_Join(aWrd$(), aSep$()) As String
Dim tx$, n&
For n = 1 To UBound(aWrd)
tx = tx & aSep(n) & aWrd(n)
Next n
PRDX_SplitString_ByNonCyrLat_Join = tx & aSep(UBound(aSep))
End Function
'==================================================================================================
Алгоритм НЕрегулярного варианта
1. Берём строку в байтовый массив. 2. В цикле по байтам определяем принадлежность очередного символа к кириллице или латинице. 3. Собираем 2 массива ("слов" и "неслов") в порядке их расположения в строке. Массив НЕслов ВСЕГДА на 1 больше, чем массив слов. Сделано это для однозначности - отдельная функция сцепляет эти массивы обратно в строку, беря 1ый элемент массива "НЕслов", прибавляя к нему 1ый элемент массива "слов" и так далее, пока массив "слов" не кончится. В конце добавляем гарантированно оставшийся элемент массива "НЕслов". Если строка начинается/заканчивается с символа "НЕслова", то будут они, если первым/последним символом является "слово", то в массиве "НЕслов" будут строки нолевой длины "". 4. Функции замены остаётся только пробежаться по массиву "слов", произвести замены и сцепить 2 массива обратно в строку
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
bedvit, есть необходимость в функции, которая принимает 2 аргумента (массив 1D или 2D с элементами для замены, двумерный массив настроек из 3ёх столбцов) и возвращает количество элементов, в которых были произведены замены. А также, меняет элементы в переданном массиве.
Скрины с описанием и примерами
Нюансы: • Ошибки и пустые пропускаются. • Элементы для замены рассматриваются, как строки. • Если произошла замена, то вместо старого элемента будет строка, даже, если после замены элемент может быть числом/датой (это надо подумать…).
Варианты инструментов: У bedvit'а в библиотеке есть функции BV.Replace (более быстрый аналог штатного) и BV.FilterUnicodeChar (для удаления символов по списку с поддержкой диапазонов и НЕудаляемого перечня). Можно сделать их аналоги для работы с массивом элементов. В таком случае, функционал предложенного комбайна можно урезать и, тем самым, повысить скорость работы. Возможно, для списка символов ("1" в качестве первой цифры строки параметров) стоит убрать возможность игнорирования регистра…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Здесь обсуждаем нюансы нелёгкого труда по сохранению облика Планеты силами наших модераторов.
Для чего эта тема создана: для предложений и уточнений.
Например, реальное предложение: больше учитывать мнение и позицию ТСа по ведению его темы, если это не идёт в разрез с логикой и Правилами сайта. По просьбе ТСа принимать меры по очищению темы от флуда, выставлению предупреждений виновным, а также замечаний и бана — в случае непонимания. UPD 10/05/2023: Создать и закрепить под Правилами в общей ветке тему "Что делать, если мою тему удалили" и там описать, чтобы пользователь несколько раз внимательно прочёл Правила сайта и подумал, что он сделал не так. Профит в том, что модерам меньше пустой работы "попугаями".
Для чего эта тема НЕ годится: для обсуждений действий модераторов, будь то критика или похвала.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄