Приветствую! Прошу поделиться опытом использования и рекомендациями, у кого есть.
Суть: Я часто скачиваю музыку и подкасты на телефон в виде аудио-файлов (чаще всего это "*.mp3"). Приложение должно для каждого файла запоминать (или давать возможность запомнить) тот момент, на котором произошла пауза воспроизведения. И хранить это в основной памяти. Чтобы я мог закрыть приложение, открыть через неделю и продолжить прослушивание с нужного момента. Как вы понимаете, этот функционал — для подкастов, книг и прочего длительного. В музыке я не настолько требователен .
Изменено: - 30.05.2024 13:46:08
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
[ Закрыто] Как работать с архивами?, VBA. How to work with archives. Method «Shell32.Namespace», Program «7z» and others
Приветствую! Начинаю цикл тем о работе с архивами — чтобы зафиксировать полученный опыт для себя и других. Шапка темы (этот пост) будет обновляться — здесь будут фиксироваться готовые приёмы и задаваться очередные вопросы для последующего разбора в постах темы. Оставляю за собой право на ошибки и неточности. Прошу сообщать при их обнаружении. Пока набросаю черновик — займусь, как будет время.
7z: Внутри архива пути начинаются с имён папок (или сразу имён файлов) и это имеет значение при удалении. То есть, чтобы удалить файлы test.txtвезде мне нужен ключ -r (рекурсивный поиск), если только в корне архива — без этого ключа и та же маска test.txt, если же нужно удалить это файл только в конкретной папке, то путь загоняем в маску: fold1\fold2\test.txt. Чтобы удалить все файлы (вместе с папкой, к сожалению или счастью) из папки, маску делаем: fold1\fold2\* Вариант fold1\fold2\*.xmlтакже удалит и саму папку fold2, если в ней только xml-файлы.
Изменено: - 22.05.2024 11:34:35
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Как использовать командную строку?, VBA. How to use Cmd. Function «Shell()», Object «WshShell» and others
По этим условиям, написать формулу. Не такую громоздкую. Спасибо
Модератор отвечает
Для того, что-бы помочь Вам с формулой, нужно знать ЧТО она считает. Как только сформулируете эту мысль, так сразу же создайте новую тему с соответствующим названием. Закрыто
Я всё понимаю — замыленный глаз, много нарушений, но, может хватит уже докапываться ЗАЧЕМ, если вопрос именно в ТЕХНИКЕ? Какая разница ЧТО считает эта формула, если просят просто её СОКРАТИТЬ? Блин, да в той теме даже файл-пример БЫЛ! Перед этой закрыли другую её о том же.
Изменено: - 15.05.2024 15:01:39
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Словарь быстрее наполняется, если ключи для него отсортированы, Sorted Keys is good for Dictionary
Приветствую! Заметил ещё одно очень странное поведение словарей — скорость заполнения/проверки наличия сильно зависит от порядка ключей в массиве. Отсортированные ключи добавляются/проверяются намного быстрее (~ 6 раз на примере). Для сравнения добавил карты Виталия из библы — тоже есть различие, но на уровне погрешности.
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
'Dim BV As New BedvitCOM.VBA
'==================================================================================================
Sub PRDX_SortRecur_WithInd(aV(), aI() As Long, LBnd&, UBnd&)
Dim i&, j&, n&, x, y
i = LBnd: j = UBnd: x = aV((LBnd + UBnd) \ 2)
Do
While (aV(i) < x): i = i + 1: Wend
While (x < aV(j)): j = j - 1: Wend
If (i <= j) Then
y = aV(i): aV(i) = aV(j): aV(j) = y
n = aI(i): aI(i) = aI(j): aI(j) = n
i = i + 1: j = j - 1
End If
Loop Until (i > j)
If (LBnd < j) Then PRDX_SortRecur_WithInd aV, aI, LBnd, j
If (i < UBnd) Then PRDX_SortRecur_WithInd aV, aI, i, UBnd
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function PRDX_Sort_Arr2D(a2D, Optional ByVal nCol& = 1) As Variant
Dim aNew, aVal(), aInd&(), r&, rr&, c&
r = UBound(a2D, 1)
ReDim aVal(r), aInd(r)
For r = 1 To UBound(aInd)
aInd(r) = r
aVal(r) = a2D(r, nCol)
Next r
PRDX_SortRecur_WithInd aVal, aInd, 1, UBound(aInd)
ReDim aNew(UBound(a2D, 1), UBound(a2D, 2)): r = 0
For r = 1 To UBound(a2D, 1)
rr = aInd(r)
For c = 1 To UBound(a2D, 2)
aNew(r, c) = a2D(rr, c)
Next c
Next r
PRDX_Sort_Arr2D = aNew
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
'==================================================================================================
Sub CreateArr2Col(aOut, nUniq&, nRepeats&, Optional UnSort As Boolean)
Dim n&, r&, p&
If UnSort Then
ReDim aOut(nUniq * (1 + nRepeats), 3) ' Key, Value, Sort(Optional Temp)
Else
ReDim aOut(nUniq * (1 + nRepeats), 2)
End If
For n = 1 To nUniq
r = r + 1
aOut(r, 1) = "Key_" & n
aOut(r, 2) = "Val_" & r
If UnSort Then aOut(r, 3) = Rnd()
For p = 1 To nRepeats
r = r + 1
aOut(r, 1) = aOut(r - 1, 1)
aOut(r, 2) = "Val_" & r
If UnSort Then aOut(r, 3) = Rnd()
Next p
Next n
If Not UnSort Then Exit Sub
aOut = PRDX_Sort_Arr2D(aOut, 3)
'BV.ArraySortV aOut, 3
ReDim Preserve aOut(UBound(aOut), 2)
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub Test_Add()
Dim dic As New Dictionary
Dim x, a, t!, r&
' UnSort ----------------------------------------
t = Timer
CreateArr2Col a, 50000, 100, True
Debug.Print Round(Timer - t, 2), "CreateArr(UnSort)" ' 14.3
t = Timer
For r = 1 To UBound(a, 1)
x = dic(a(r, 1))
Next r
Debug.Print Round(Timer - t, 2), "Test(UnSort)" ' 2.9
dic.RemoveAll
' Sort ------------------------------------------
t = Timer
CreateArr2Col a, 50000, 100
Debug.Print Round(Timer - t, 2), "CreateArr(Sort)" ' 2.6
t = Timer
For r = 1 To UBound(a, 1)
x = dic(a(r, 1))
Next r
Debug.Print Round(Timer - t, 2), "Test(Sort)" ' 0.5
End Sub
'==================================================================================================
Private Sub Test_Exists()
Dim dic As New Dictionary
Dim a, s$, t!, r&
' UnSort ----------------------------------------
t = Timer
CreateArr2Col a, 50000, 100, True
Debug.Print Round(Timer - t, 2), "CreateArr(UnSort)" ' 14.3
t = Timer
For r = 1 To UBound(a, 1)
s = a(r, 1)
If Not dic.Exists(s) Then dic.Add s, 0
Next r
Debug.Print Round(Timer - t, 2), "Test(UnSort)" ' 3.1
'Debug.Print UBound(a, 1)
dic.RemoveAll
' Sort ------------------------------------------
t = Timer
CreateArr2Col a, 50000, 100
Debug.Print Round(Timer - t, 2), "CreateArr(Sort)" ' 2.6
t = Timer
For r = 1 To UBound(a, 1)
s = a(r, 1)
If Not dic.Exists(s) Then dic.Add s, 0
Next r
Debug.Print Round(Timer - t, 2), "Test(Sort)" ' 0.7
'Debug.Print UBound(a, 1)
End Sub
'==================================================================================================
Private Sub Test_ResumeNext()
Dim dic As New Dictionary
Dim a, t!, r&
On Error Resume Next
' UnSort ----------------------------------------
t = Timer
CreateArr2Col a, 50000, 100, True
Debug.Print Round(Timer - t, 2), "CreateArr(UnSort)" ' 14.6
t = Timer
For r = 1 To UBound(a, 1)
dic.Add a(r, 1), 0
Next r
Debug.Print Round(Timer - t, 2), "Test(UnSort)" ' 6.7
'Debug.Print UBound(a, 1)
dic.RemoveAll
' Sort ------------------------------------------
t = Timer
CreateArr2Col a, 50000, 100
Debug.Print Round(Timer - t, 2), "CreateArr(Sort)" ' 2.5
t = Timer
For r = 1 To UBound(a, 1)
dic.Add a(r, 1), 0
Next r
Debug.Print Round(Timer - t, 2), "Test(Sort)" ' 4.2
'Debug.Print UBound(a, 1)
On Error GoTo 0
End Sub
'==================================================================================================
' Need BedVit.COM library: https://bedvit.ru/com/
Private Sub Test_Map()
Dim map As New BedvitCOM.UnorderedMap
Dim a, t!, r&
On Error Resume Next
' UnSort ----------------------------------------
t = Timer
CreateArr2Col a, 50000, 100, True
Debug.Print Round(Timer - t, 2), "CreateArr(UnSort)" ' 14.4
t = Timer
For r = 1 To UBound(a, 1)
map.Insert a(r, 1), 0
Next r
Debug.Print Round(Timer - t, 2), "Test(UnSort)" ' 1.6
'Debug.Print UBound(a, 1)
map.Clear
' Sort ------------------------------------------
t = Timer
CreateArr2Col a, 50000, 100
Debug.Print Round(Timer - t, 2), "CreateArr(Sort)" ' 2.5
t = Timer
For r = 1 To UBound(a, 1)
map.Insert a(r, 1), 0
Next r
Debug.Print Round(Timer - t, 2), "Test(Sort)" ' 1.4
'Debug.Print UBound(a, 1)
On Error GoTo 0
End Sub
'==================================================================================================
Не перестаю удивляться VBA
Изменено: - 03.05.2024 14:19:56
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
СцепитьЕсли. Эффективный и универсальный алгоритм, JoinIf
Представляю 1 основной способ — Progressive. + один "в лоб" (для примера) + один — с помощью массивов, но он никуда не годится. + один на основе Mid$() =. От него ничего реально качественного добиться (для универсальности) не вышло. Наверное, что-то можно подкрутить.
Что не исследовано: • метод скуля. То есть, отсортировать поле ключей и "сгруппировать" по ним, сцепляя строки. • контроль уникальности сцепляемых строк. С учётом регистра и без него.
Что-то из этого или всё сразу будет во втором тесте — с победителями (Progressive и Middle).
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' aKeys_Out() and aJoin_Out() have LBound = 0
Sub Simple(a2Col_In, sSep_In$, aKeys_Out(), aJoin_Out())
Dim dic As New Dictionary
Dim s$, r&
For r = 1 To UBound(a2Col_In, 1)
s = a2Col_In(r, 1)
If dic.Exists(s) Then
dic(s) = dic(s) & sSep_In & a2Col_In(r, 2)
Else
dic.Add s, a2Col_In(r, 2)
End If
Next r
aKeys_Out = dic.Keys
aJoin_Out = dic.Items
End Sub
'==================================================================================================
Sub Progressive(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim dic As New Dictionary
Dim s$, r&, n&, p&
r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r)
For r = 1 To UBound(a2Col_In, 1)
s = a2Col_In(r, 1)
p = dic(s)
If (p = 0) Then
n = n + 1: dic(s) = n
aKeys_Out(n) = s
aJoin_Out(n) = a2Col_In(r, 2)
Else
aJoin_Out(p) = aJoin_Out(p) & sSep_In & a2Col_In(r, 2)
End If
Next r
ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
Sub Middle(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim dic As New Dictionary
Dim aPos&()
Dim s$, sps$, t!, r&, n&, p&, l&, lSep&, lPos&, ll&
Const lBuf& = 1000
sps = Space$(lBuf): lSep = Len(sSep_In): r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r), aPos(r)
't = Timer
For r = 1 To UBound(a2Col_In, 1)
s = a2Col_In(r, 1)
p = dic(s)
If (p = 0) Then
n = n + 1: dic(s) = n
aKeys_Out(n) = s
s = a2Col_In(r, 2): l = Len(s)
aJoin_Out(n) = sps
Mid$(aJoin_Out(n), 1, l) = s
aPos(n) = l
Else
s = a2Col_In(r, 2): l = Len(s)
lPos = aPos(p): ll = lPos + lSep + l
If (ll > lBuf) Then
aJoin_Out(p) = Left$(aJoin_Out(p), aPos(p)) & sSep_In & s
Else
Mid$(aJoin_Out(p), lPos + 1, lSep) = sSep_In
Mid$(aJoin_Out(p), lPos + 1 + lSep, l) = s
End If
aPos(p) = ll
End If
Next r
'Debug.Print Round(Timer - t, 2), "Middle(Main)"
ReDim Preserve aKeys_Out(n), aJoin_Out(n)
't = Timer
For n = 1 To n
aJoin_Out(n) = Left$(aJoin_Out(n), aPos(n))
Next n
'Debug.Print Round(Timer - t, 2), "Middle(Cut)"
End Sub
'==================================================================================================
Sub ArrJoin(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim dic As New Dictionary
Dim aArr(), aJ$(), aJ2$(), aCnt&()
Dim s$, sps$, t!, r&, n&, p&, cnt&
r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aArr(r), aCnt(r)
r = r / 10: If (r < 1000) Then r = 1000
ReDim aJ(r)
t = Timer
For r = 1 To UBound(a2Col_In, 1)
s = a2Col_In(r, 1)
p = dic(s)
If (p = 0) Then
n = n + 1: dic(s) = n
aKeys_Out(n) = s
aJ(1) = a2Col_In(r, 2): aArr(n) = aJ
aCnt(n) = 1
Else
cnt = aCnt(n): aJ2 = aArr(n)
If (cnt = UBound(aJ2)) Then ReDim Preserve aJ2(2 * cnt)
cnt = cnt + 1: aCnt(n) = cnt
aJ2(cnt) = a2Col_In(r, 2): aArr(n) = aJ2
End If
DoEvents
Next r
Debug.Print Round(Timer - t, 2), "ArrJoin(Main)"
ReDim Preserve aKeys_Out(n)
ReDim aJoin_Out(n)
t = Timer
For n = 1 To n
aJ = aArr(n): ReDim Preserve aJ(aCnt(n))
aJoin_Out(n) = Join(aJ, sSep_In)
Next n
Debug.Print Round(Timer - t, 2), "ArrJoin(Cut)"
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Sub CreateArr2Col(aOut, nUniq&, nRepeats&)
Dim n&, r&, p&
ReDim aOut(nUniq * (1 + nRepeats), 2) ' Key, Value
For n = 1 To nUniq
r = r + 1
aOut(r, 1) = "Key_" & n
aOut(r, 2) = "Val_" & r
For p = 1 To nRepeats
r = r + 1
aOut(r, 1) = aOut(r - 1, 1)
aOut(r, 2) = "Val_" & r
Next p
Next n
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub Test()
Dim aK(), aV(), aKs$(), aVs$()
Dim a, t!
Const sep = ", "
t = Timer ' Repeats
CreateArr2Col a, 100000, 0 ' 0 | 10 | 100
Debug.Print Round(Timer - t, 2), "CreateArr" ' 0.1 | 0.4 | 3.5
t = Timer
Simple a, sep, aK, aV
Debug.Print Round(Timer - t, 2), "Simple" ' 0.3 | 0.8 | 6.5
'Debug.Print aK(99), "«" & aV(99) & "»"
t = Timer
Progressive a, sep, aKs, aVs
Debug.Print Round(Timer - t, 2), "Progressive" ' 0.2 | 0.6 | 4.7
'Debug.Print aKs(100), "«" & aVs(100) & "»"
t = Timer
Middle a, sep, aKs, aVs
Debug.Print Round(Timer - t, 2), "Middle" ' 0.3 | 0.6 | 4.0
'Debug.Print aKs(100), "«" & aVs(100) & "»"
't = Timer
' ArrJoin a, sep, aKs, aVs
'Debug.Print Round(Timer - t, 2), "ArrJoin" ' OUT !!!
''Debug.Print aKs(100), "«" & aVs(100) & "»"
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Что нужно? Предложите более качественный алгоритм (возможно, на основе MidB() ).
Основная проблема: никогда заранее неизвестно, сколько уникальных ключей содержится в массиве и, сколько по каждому из них будет сцеплено значений. Массив может состоять только из ключей и тогда для каждого ключа будет только одно значение. Массив может состоять из одного ключа и тогда все значения нужно сцепить в одну строку (которая ещё может и не влезть в ячейку).
Если bedvit'у будет интересно, то предлагаю сделать такую процедуру — я протестирую.
В итоге, такая процедура должна принимать:
1. Двумерный массив (Dim arr). 2. Номер поля ключей в двумерном массиве. Long. 3. Номер поля значений (для сцепки) в двумерном массиве. Long. 4. Разделитель для сцепки. String. 5. Одномерный (от 1) стринговый массив ключей для возвращения. 6. Одномерный (от 1) стринговый массив сцепленных значений (соответствует позициям ключей). 7. ТолькоУникальные. Optional As Boolean. 8. ИгнорРегистра (при определении уникальности сцепляемых строк). Optional As Boolean.
Возможно, имеет смысл сразу сделать комбайн (как для фильтра) — процедуру группировки двумерного массива со следующими аргументами:
1. Двумерный массив для группировки (Dim arr). 2. Двумерный массив для вывода результата (Dim arr). 3. Одномерный массив номеров полей, по которым производится группировка. 4. Двумерный массив или строка с параметрами вида Ncol — Ntype, с помощью которой можно указать, какие действия нужно совершить с полями НЕ УЧАСТВУЮЩИМИ в группировке. • Ncol — номер столбца (от 1) в двумерном массиве. Не должен участвовать в группировке. • Ntype — тип агрегации (целое число по определённой таблице). Сумма(только числа), среднее(только числа), минимум, максимум, сцепка. 5. Опциональное булево: вывести новым последним полем количество сгруппированных строк.
Изменено: - 02.05.2024 17:27:39
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
"Статичный" фильтр. Как ускорить фильтрацию двумерного массива, Static Filter. How to SpeedUp Filter of 2D-Array
Приветствую! Заинтересовался такой задачей: как можно ускорить фильтрацию двумерного массива? Далее под "фильтрацией таблицы" будет иметься в виду отбор строк двумерного массива, согласно критериев.
Давайте разбираться, что такое отбор/фильтрация на примере двумерного массива из таблицы
Итак, у нас есть тело (все данные без заголовков и итогов) Таблицы в виде двумерного массива a2D. В этом массиве rT (UBound (a2D, 1) ) строк и cT (UBound (a2D, 2) ) столбцов. Мы можем определить из этого массива cF полей, по которым мы хотим фильтровать таблицу. То есть: cT >= cF > 0. В общем смысле, фильтрация таблицы — это пересборка исходной таблицы с сохранением только тех строк, значения в которых по фильтруемым полям соответствуют условиям для этих полей.
Например, если я фильтрую таблицу по полю "Фамилия" и передаю критерий "Петров" и, также, фильтрую по полю "Имя" и передаю критерий "Василий", то, это значит, что я должен пройти по всем строкам Таблицы и оставить только те, у которых в поле "Фамилия" записано "Петров", а в поле "Имя" записано "Василий". И никак иначе.
Я решил разобрать [относительно] простой случай: Отбор не более, чем по одному значению — для каждого поля. Проверка осуществляется на строгое равенство, с учётом регистра. Алгоритм ускорения позволяет осуществить, также, проверку без учёта регистра и/или на НЕравенство, но в примере это не отражено.
Итак, как же ускорить? Чтобы ускорить, нужно как-то избавиться от цикла по всем строкам таблицы. Для этого нужно как-то запомнить строки для каждого критерия в фильтруемых столбцах и хранить их в ОЗУ (использовать статичные переменные). То есть, в любом случае, нужно собрать уникальные списки для каждого поля, которое хотим фильтровать.
Далее существует, минимум, 2 сценария:
• простой. Если количество комбинаций между всеми уникальными списками не выше порога (например, 100 млн), то можно использовать словарь (для не более чем 100 тыс. ключей )или массив словарей (для большего количества). Или суперсловарь от bedvit'а, у которого нет ограничения по ключам. Далее, мы "просто" получаем все эти комбинации и, для каждой из них, собираем массив строк, которые этой комбинации соответствуют. Пара: комбинация — массив. Тут ограничением является количество комбинаций — на 100 или даже 10 млн время получения этих комбинаций и массивов по ним может превысить допустимое время ожидания пользователя (устанавливается индивидуально). Если время формирования вас устраивает, то дальше всё просто: получаем параметры для фильтрации каждого поля, сцепляем в строку (по тем же правилам, как и при формировании ключей словаря) и, если такая строка есть в словаре, то просто получаем массив строк Таблицы и отбираем из неё в новый двумерный массив. Помимо относительной простоты, этот способ будет самым быстрым в получении массива строк по переданным параметрам. Кто считает, что такое (100 млн) количество комбинаций просто немыслимо напомню, что это, например 100 ^4, то есть, всего лишь 4 поля по 100 уникальных записей (минимальное количество комбинаций это произведение всех уникальных списков). И это минимум, потому что, если учитывать, что фильтры могут быть заданы НЕ для всех полей (как в примере) то это количество может быть значительно больше. • сложный. Что же делать, если 1ый вариант нас не устраивает? Как-то уйти от затратных по сбору комбинаций, очевидно. Я предлагаю [и показываю, как] собирать массив словарей, размером с количество полей, которые могут участвовать в фильтрации. Каждый элемент этого массива (словарь) содержит пары "критерий — массив строк". То есть, такой словарь для поля будет содержать столько ключей, сколько уникальных значений для этого поля. И для каждого ключа/значения будет содержать список строк, в которых оно встречается. Так мы уходим от необходимости комбинировать все возможные варианты сочетаний критериев. Это и было целью. Остаётся, при получении параметров отбора, найти в словарях все массивы со строками и, самое важное, найти ПЕРЕСЕЧЕНИЕ этих строк — то есть те номера строк, которые есть во всех отобранных массивах. Например, если передали только критерии для 2ух полей: Фамилия (= "Петров") и Имя (= "Василий"), то мы из соответствующих словарей (элементов массива словарей) находим список строк для (= "Петров"): {1, 2, 15, 89, 156} и для (= "Василий"): {3, 81 11, 15, 264} и понимаем/вычисляем, что общая строка у них всего одна (#15), а, значит и результирующий набор вывода будет состоять только из одной строки исходной таблицы.
Слабые места алгоритма, которые я хотел бы ускорить (существующими методами или библой bedvit'а): • сцепка по ключу (не очень страшно и есть альтернативы). Чтобы собрать номера строк в массив я использую накопительную строку, формируемую по принципу s = s & sSep & iRow. Есть и другие варианты ( Mid$(s, …) = sSep & iRow кажется самым быстрым, но сложнее в реализации). • определение общих значений (отсортированные целые числа) для N массивов. Тут я применил всё, что знал. Используется массив в качестве "словаря" для быстрой проверки и используется самый малый по размеру массив (т.к. если в нём нет номера строки, то она уже никак не может быть общей для всех массивов). Описывать очень долго — кто в теме, тот поймёт. Какие-то моменты всегда можно спросить и я отвечу. Так вот, для этого процесса мне бы очень не помешал специальный инструмент из библы — такие штуки на плюсах должны быть сильно быстрее. Думаю, что его применение может быть довольно широким.
Возможно, есть и другие способы, как ускорить отбор. Прошу поделиться
В файле 2 листа: исходная таблица для фильтрации и тестовый. В таблице можно добавлять/удалять строки. При уходе с листа произойдёт обновление. На тестовом можно выбрать от 1 до 4ёх критериев фильтра и нажать(даблклик) FILTER — справа выведется отфильтрованная таблица или сообщение, что под заданные параметры ничего не найдено.
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Work
'==================================================================================================
Function PRDX_StrToArrL(sIn$, sep$, aL_Out() As Long) As Boolean
Dim x, arr, n&
arr = Split(sIn, sep)
ReDim aL_Out(UBound(arr) + 1)
For Each x In arr
n = n + 1: aL_Out(n) = x
Next x
PRDX_StrToArrL = True
End Function
'==================================================================================================
' ' Faster than Dictionary
Function PRDX_ArrL_ChangeIndVal(aIn() As Long, aOut() As Long, Optional SetVal&) As Boolean
Dim UBnd&, r&, i&, n&
UBnd = 2 * UBound(aIn)
ReDim aOut(UBnd)
For r = 1 To UBound(aIn)
i = aIn(r): If (UBnd < i) Then UBnd = 2 * i: ReDim Preserve aOut(UBnd)
If (SetVal = 0) Then aOut(i) = r Else aOut(i) = SetVal
If (n < i) Then n = i
Next r
ReDim Preserve aOut(n)
PRDX_ArrL_ChangeIndVal = True
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_ArrL_ChangeIndVal()
Dim a&(), b&(), n&
PRDX_StrToArrL "5/3/2", "/", a
For n = 1 To UBound(a)
Debug.Print "a(" & n & ") = " & a(n) ' a(1) = 5; a(2) = 3; a(3) = 2
Next n
Debug.Print String$(20, "-")
PRDX_ArrL_ChangeIndVal a, b
For n = 1 To UBound(b)
Debug.Print "b(" & n & ") = " & b(n) ' b(1) = 0; b(2) = 3; b(3) = 2; b(4) = 0; b(5) = 1
Next n
Debug.Print String$(20, "-")
PRDX_ArrL_ChangeIndVal a, b, 100
For n = 1 To UBound(b)
Debug.Print "b(" & n & ") = " & b(n) ' b(1) = 0; b(2) = 100; b(3) = 100; b(4) = 0; b(5) = 100
Next n
End Sub
'==================================================================================================
' Main
'==================================================================================================
Private Function FillDic(a2D, nCol&, dicOut As Dictionary) As Boolean
Dim x, arr, aJ$(), aRows&()
Dim s$, r&, n&, nn&
Const sep$ = " "
Set dicOut = New Dictionary
ReDim aJ(UBound(a2D, 1), 2) ' Key, Join
For r = 1 To UBound(a2D, 1)
s = a2D(r, nCol)
If dicOut.Exists(s) Then
nn = dicOut(s): aJ(nn, 2) = aJ(nn, 2) & sep & r ' Slow
Else
n = n + 1: dicOut.Add s, n: aJ(n, 1) = s: aJ(n, 2) = r
End If
Next r
dicOut.RemoveAll
For r = 1 To n ' Convert "1 2 3" to Array(1, 2, 3) As Long
If Not PRDX_StrToArrL(aJ(r, 2), sep, aRows) Then Stop: End
dicOut.Add aJ(r, 1), aRows
Next r
FillDic = True
End Function
'==================================================================================================
Function PRDX_Tbl_ReCalc(a2D_Tbl, a1D_ColFilt, aDic_Out() As Dictionary) As Boolean
Dim x, n&
ReDim aDic_Out(UBound(a1D_ColFilt))
For Each x In a1D_ColFilt
n = n + 1: If Not FillDic(a2D_Tbl, --x, aDic_Out(n)) Then Stop: End
Next x
PRDX_Tbl_ReCalc = True
End Function
'==================================================================================================
'==================================================================================================
' Filter
'==================================================================================================
Private Function RowsOfDic(a1D_ColFilt, a1D_ColVal, a1D_ColIV, aDic() As Dictionary, aArrRows_Out()) As Boolean
Dim s$, n&, i&, p&
ReDim aArrRows_Out(UBound(a1D_ColIV))
For n = 1 To UBound(a1D_ColFilt)
i = a1D_ColIV(a1D_ColFilt(n)) ' Index of Col# a1D_ColFilt(n) in aDic()
If (i <> 0) Then
s = a1D_ColVal(n)
If aDic(i).Exists(s) Then p = p + 1: aArrRows_Out(p) = aDic(i)(s)
End If
Next n
If (p = 0) Then Exit Function
ReDim Preserve aArrRows_Out(p): RowsOfDic = True
End Function
'==================================================================================================
Private Function RowsInsersect(aArrRows(), aRows_Out() As Long) As Boolean
Dim x, aVI&()
Dim iMin&, UBnd&, n&, i&
If (UBound(aArrRows) = 1) Then aRows_Out = aArrRows(1): GoTo fn
iMin = UBound(aArrRows(1)): i = 1
For n = 2 To UBound(aArrRows) ' Find Minimal Array
UBnd = UBound(aArrRows(n))
If (iMin > UBnd) Then iMin = UBnd: i = n
Next n
aRows_Out = aArrRows(i) ' Set Minimal Array
If Not PRDX_ArrL_ChangeIndVal(aRows_Out, aVI, 1) Then Stop: End ' Set Array Like "Dictionary"
ReDim aRows_Out(UBound(aRows_Out))
On Error Resume Next
For n = 1 To UBound(aArrRows) ' Filter aRows_Out
If (n <> i) Then
For Each x In aArrRows(n)
aVI(x) = aVI(x) + 1
Next x
End If
Next n
On Error GoTo 0
n = 0: i = 0: UBnd = UBound(aArrRows)
For i = 1 To UBound(aVI)
If (aVI(i) = UBnd) Then n = n + 1: aRows_Out(n) = i
Next i
If (n = 0) Then Exit Function
ReDim Preserve aRows_Out(n)
fn: RowsInsersect = True
End Function
'==================================================================================================
Function PRDX_Tbl_Filter_GetRows(a1D_ColFilt, a1D_ColVal, a1D_ColIV, aDic() As Dictionary, aRows_Out() As Long) As Boolean
Dim aArrR()
If Not RowsOfDic(a1D_ColFilt, a1D_ColVal, a1D_ColIV, aDic, aArrR) Then Exit Function
PRDX_Tbl_Filter_GetRows = RowsInsersect(aArrR, aRows_Out)
End Function
'==================================================================================================
Function PRDX_Tbl_Filter_Arr2D(a2D_In, a2D_Out, aRows() As Long) As Boolean
Dim r&, rr&, c&
ReDim a2D_Out(UBound(aRows), UBound(a2D_In, 2))
For r = 1 To UBound(aRows)
rr = aRows(r)
For c = 1 To UBound(a2D_In, 2)
a2D_Out(r, c) = a2D_In(rr, c)
Next c
Next r
PRDX_Tbl_Filter_Arr2D = True
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
Модуль «PRDX_Example»
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public vp_aDic() As Dictionary, vp_aCol&(), vp_aColIV&()
'==================================================================================================
Function PRDX_Ex_TblUpdate(Optional Force As Boolean) As Boolean
Dim a
Static st&
If (st = 1) Then If Force Then st = 0 Else GoTo fn
If Not PRDX_StrToArrL("2/3/4/5", "/", vp_aCol) Then Stop: End
If Not PRDX_ArrL_ChangeIndVal(vp_aCol, vp_aColIV) Then Stop: End
a = shTbl.ListObjects(1).DataBodyRange.Value2
If Not PRDX_Tbl_ReCalc(a, vp_aCol, vp_aDic) Then Stop: End
st = 1
fn: PRDX_Ex_TblUpdate = True
End Function
'==================================================================================================
'==================================================================================================
Private Function GetFilter(aCol_Out() As Long, aVal_Out() As String) As Boolean
Dim arr, c&, n&
arr = shUniq.Range("A2:D2").Value2
ReDim aCol_Out(UBound(arr, 2)): ReDim aVal_Out(UBound(aCol_Out))
For c = 1 To UBound(arr, 2)
If Not IsEmpty(arr(1, c)) Then n = n + 1: aCol_Out(n) = c + 1: aVal_Out(n) = arr(1, c)
Next c
If (n = 0) Then Exit Function
ReDim Preserve aCol_Out(n), aVal_Out(n)
GetFilter = True
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_Ex_TblFilter() As Boolean
Dim cl As Range
Dim aTbl, aFlt(), aCol&(), aRows&(), aVal$()
If Not GetFilter(aCol, aVal) Then Exit Function
If Not PRDX_Ex_TblUpdate() Then Stop: End
Set cl = shUniq.Range("I5")
cl.Resize(shUniq.UsedRange.Rows.Count, 5).ClearContents
If Not PRDX_Tbl_Filter_GetRows(aCol, aVal, vp_aColIV, vp_aDic, aRows) Then Exit Function
aTbl = shTbl.ListObjects(1).DataBodyRange.Value2
If Not PRDX_Tbl_Filter_Arr2D(aTbl, aFlt, aRows) Then Stop: End
cl.Resize(UBound(aFlt, 1), UBound(aFlt, 2)).Value2 = aFlt
PRDX_Ex_TblFilter = True
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
Изменено: - 27.04.2024 17:26:11
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Очередной элемент массива словарей заменяет все предыдущие на себя, Each new element of ArrayDictionary replaced all old elements with itself
Приветствую! Столкнулся со странным поведением массива словарей. Добавление очередного элемента вызывает замещение предыдущих на него же. Как обойти — показал, но, мне кажется, что заполнение словаря, как элемента массива будет дольше, ведь нужно постоянно обращаться к массиву.
Код
Код
Private Sub Fill(dic As Dictionary, sPref$)
dic.RemoveAll
dic.Add sPref & "_1", 1
dic.Add sPref & "_2", 2
dic.Add sPref & "_3", 3
End Sub
'==================================================================================================
Private Sub Test_Bad()
Dim dic As New Dictionary
Dim aDic() As Dictionary ' As New Dictionary Also Bad
ReDim aDic(3)
Fill dic, "a": Set aDic(1) = dic
Debug.Print "a", Join(aDic(1).Keys) ' a_1 a_2 a_3
Fill dic, "b": Set aDic(2) = dic
Debug.Print "a", Join(aDic(1).Keys) ' b_1 b_2 b_3
Debug.Print "b", Join(aDic(2).Keys) ' b_1 b_2 b_3
Fill dic, "c": Set aDic(3) = dic
Debug.Print "a", Join(aDic(1).Keys) ' c_1 c_2 c_3
Debug.Print "b", Join(aDic(2).Keys) ' c_1 c_2 c_3
Debug.Print "c", Join(aDic(3).Keys) ' c_1 c_2 c_3
End Sub
'==================================================================================================
Private Sub Test_Good()
Dim aDic() As New Dictionary
ReDim aDic(3)
Fill aDic(1), "a"
Debug.Print "a", Join(aDic(1).Keys) ' a_1 a_2 a_3
Fill aDic(2), "b"
Debug.Print "a", Join(aDic(1).Keys) ' a_1 a_2 a_3
Debug.Print "b", Join(aDic(2).Keys) ' b_1 b_2 b_3
Fill aDic(3), "c"
Debug.Print "a", Join(aDic(1).Keys) ' a_1 a_2 a_3
Debug.Print "b", Join(aDic(2).Keys) ' b_1 b_2 b_3
Debug.Print "c", Join(aDic(3).Keys) ' c_1 c_2 c_3
End Sub
Почему так и как ещё можно побороть? Судя по тестам, при Set aDic(1) = dic создаётся СВЯЗЬ между элементом массива и этим временным словарём, и, заполняя временный словарь, я сразу заполняю и элемент массива …
Изменено: - 27.04.2024 14:54:28
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Получить Nое по счёту минимальное/максимальное число из диапазона, Get PosN Extremum(Min/Max) from Range
Работает с максимумом (по умолчанию) и минимумом (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го экстремума (самое мин/макс). Для этого есть штатные функции.
Изменено: - 04.04.2024 11:32:12
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Хранение структурированных данных (таблиц) в памяти и скорость доступа к ним, How to keep Data in RAM and get it Fast
Приветствую! В одном из моих проектов возникла необходимость хранить в памяти несколько небольших одинаковых по полям табличек и очень часто получать из них информацию по индексам. То есть, вводные данные — 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 — для превращения безликих индексов в осмысленные параметры.
Изменено: - 21.03.2024 11:11:05
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Личка. Письма на форуме. Зачем может быть нужно перемещать отправленные во входящие и обратно?
Приветствую! Собственно, вопрос задан. Я причин не вижу. Более того, только что промахнулся с кнопкой и нажал ОК (также называется) возле окошка "Переместить во входящие" вместо "Ответить". И сколько так писем потерялось у людей …
Это просто очень глупо — так делать компоновку формы диалога…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Определение расстояния между 2мя точками на сфере (планета Земля) по координатам
Приветствую! Наткнулся на интересную (что редкость) и решил разобрать у себя. Формула от ТС оказалась гораздо короче и немного быстрее (при переносе на VBA), чем алгоритм с сайта. Кросс-таблица из темы ТСа преобразована в плоскую для удобства расчёта и сравнения. Несоответствие результата алгоритма (сайт "Gis-Lab") с проверочным (там же) — в том, что радиус Земли принят не совсем корректный (6 372 795 вместо 6 371 009 из Вики)
Итак. на повестке изображения аватаров. Что говорят правила? • Запрещено: 3.2. … Создавать аватары порнографического, политического или религиозного содержания. Администрация вправе удалить такого пользователя без предупреждения. Также есть запрет на рекламу к в том числе в качестве аватара.
Что делать, например, с автарами? Мне, например, очень не нравится эта всратая бабка. Она страшная, неприятная. Я бы не хотел, чтобы подобное было у меня тут в ленте. Я не вижу ни единой причины ставить такое в качестве своего аватара — я бы таких людей проверял на психические отклонения.
А, если на форум зайдёт ребёнок? У нас полно обучающих Приёмов и видео. Я не моралфаг, но у нас же не двач или фочан (ничего против них не имею, кстати), чтобы подобное считалось нормой.
А если, кто-то поставит на аватар изображение трупа/казни? Есть ещё эротика (не порнография). Также, можно в качестве аватара использовать изображение или даже гифку дефекации (есть ещё легендарное видео с банкой) и прочих "интересных" для общества явлений. На данный момент, это в рамках правил.
Почему бы не использовать давно придуманную норму или обобщить правила до "уместных" (определяется модераторами) для общественного (можно даже сказать "образовательного") форума изображений?
А то, распятие, которое многие на шее показательно носят (иногда — огромного размера), я не могу поставить (не то, чтобы я хотел — это просто пример), зато всякую погань — пожалуйста.
Изменено: - 27.11.2023 12:24:03
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Приветствую! Решил агрегировать у себя сборник вариантов по различным "обобщениям" строк между собой. Тут будут храниться ссылки на темы (если оттуда) и последние версии моих кодов (возможно, некоторые будут обновляться здесь).
Начинаю с 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
Код. Процесс разбит на 2 функции.
Код
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
'==================================================================================================
Изменено: - 15.11.2023 14:07:39
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Последние несколько лет периодически возвращаюсь к идее создания "единой сметы". Я постоянно работаю со сметными данными и наличие разнообразных форм вывода (а также их изменение) сметной информации сильно усложняет процесс стандартизации сбора информации, а также плодит ошибки "человеческого фактора". А что, если будет создана сметная программа (или закон, позволяющий принимать сметы только в таком виде), которая позволит создавать файл (пока в приоритете xml формат), содержащий ВСЮ НЕОБХОДИМУЮ информацию о смете в заданном виде/структуре. Позволяющем ОДНООБРАЗНО обрабатывать (получать информацию) из ЛЮБОЙ сметы, созданной в соответствии с законодательством.
Более того, пока я думал, нечто подобное уже ввели (, ), НО основные проблемы решены НЕ БЫЛИ:
• постоянные изменения формата. Главная головная боль. Этого быть не должно. Информация должна находиться на своих местах. Если нужно ДОБАВИТЬ какую-то новую информацию, то должно быть выпущено ПОЛНОЦЕННОЕ ОПИСАНИЕ нового формата XML и ПОДРОБНОЕ СРАВНЕНИЕ с картинками отличий его от старого формата. Если какая-то информация потеряла свою актуальность, то её тэги в структуре просто будут пустыми. Это позволит создавать инструменты, собирающие данные из самых "новых" и самых "старых" смет в XML-формате. В идеале, со стороны государства должен поставляться и обновляться вместе с очередным форматом РАЗБОРЩИК, позволяющий представить информацию из XML в ЛЮБОМ необходимом виде (смета, ведомость ресурсов, расчёт стоимости ресурсов). Также. нет никакой технической сложности разработать универсальный сметный формат, включающий ВСЮ информацию на одном листе (в одном документе) без разбивки на саму смету и ведомость ресурсов. Сейчас же ситуация такая, что данные на разных "официальных" ресурсах отличаются между собой и все вместе отличаются от данных из официального приказа (привет, КСР и ФССЦ). Это должно быть исключено. Надзорный орган ОБЯЗАН ГАРАНТИРОВАТЬ ЕДИНОЕ место хранения информации, её ПОЛНОЕ СООТВЕТСТВИЕ приказам и возможность получения её в XML-формате.
• несоответствие данных между собой Если раньше код сметы из листа Source (сырые данные из программы) и в самой смете могли отличаться или сумма ресурсов из ведомости не равна сумме ресурсов из сметы, то сейчас происходит то же самое, но уже в новом XML-формате. Старые болячки не вылечены. Решение простое: когда данные предоставлены в строгом формате с известной структурой, то несложно написать (включить в официальный разборщик) программу, которая выполнит все необходимые проверки и АВТОМАТИЧЕСКИ отклонит некорректные XML. Это существенно ускорит и удешевит процесс проверки. На данный момент, огромное количество (более 80%) смет, прошедших экспертизу, содержат ГРУБЕЙШИЕ ошибки и нестыковки на огромные суммы. Возникает закономерный вопрос: а в чём, собственно, тогда была "экспертиза"…
• несоответствие ключей ресурсов справочникам или отсутствие таких ключей Проблема не относится к теме напрямую, но обозначу. Существует ОГРОМНАЯ потребность в ЕДИНОМ и ПОПОЛНЯЕМОМ (не изменяемом) справочнике ресурсов, с критерием актуальности ключа (вместо его удаления или, боже упаси, замены) и НЕИЗМЕННОЙ структурой. Опять же, технической сложности в создании такого справочника нет. Есть только проблема в сборе информации и категоризации ресурсов (всё решаемо). Основная проблема на данный момент, состоит в том, что созданием подобных справочников занимаются люди НЕВЕРОЯТНО ДАЛЁКИЕ от понимания БАЗОВЫХ ПРАВИЛ организации любого справочника.
Изменено: - 08.11.2023 09:49:03
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
«Хакерский фольклор». Происхождение некоторых известных (и не очень) терминов
Приветствую! Наткнулся на интересную (на хабре). Мне было интересно узнать [часто, совсем неочевидную] историю происхождения известных терминов.
Изменено: - 02.11.2023 11:29:26
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Универсальный парсер текстовых файлов(строк) с тэговой структурой типа XML/HTML с получением результата в двумерный массив и полным сохранением структуры, Parse XML/HTML to Array-2D
Занялся созданием парсера, т.к. на работе возникла необходимость в частой обработке XML-документов. Предполагается, что по двумерному массиву (результат работы парсера) будет возможна полная обратная конвертация в исходную структуру XML/HTML. Разработка парсера ведётся на основе XML-документа "ГЭСН". Парсер НЕ будет использовать библиотеку .
В файле — визуализация конечного результата (двумерный массив) на листе с цветовой индикацией (только для визуала). Присутствует ссылка на родительский 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
Изменено: - 17.11.2023 09:59:39
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Как правильно проверить значение на ошибки и пустые (или сразу отобрать числовые), Check for Errors and Empty (and find Num). Fast and Correct
Приветствую! Небольшое наблюдение: хотел ускорить проверку на [возможные] числовые значения или просто ускорить отсев ошибок и пустых.
Что касается отбора [возможных] числовых значений: вариант "в лоб" (с помощью супербыстрой 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
Изменено: - 10.08.2023 18:08:30
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Как определить, отключён ли 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
Изменено: - 09.08.2023 15:23:04
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Как лучше передавать аргументы в функцию или процедуру — ссылкой (ByRef) или значением (ByVal)?, ByRef or ByVal?
Приветствую! Решил тут проверить кое-что для себя и зафиксировать тут Если тип передачи аргумента не указывается, то по умолчанию используется ByRef. Иными словами, только передача аргумента значением нуждается в явном указании — ByVal. Передача аргумента по ссылке избегает его (аргумента) копирования и позволяет изменять передаваемые аргументы. Нельзя передать значением (ByVal) аргументы массивов, Но можно передавать значением аргумент типа Variant, в который запросто можно передать массив.
Справка:
Похожие темы:
Test String
Код
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) и проверить будет просто невозможно (насколько мне известно).
Выводы делайте сами
Изменено: - 08.08.2023 15:08:39
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Преобразование числа в буквы и обратно, Convert number to letters and back
Приветствую! Есть функция (идея не моя), которая генерирует условно-уникальные (возможны ситуации получения дублей) числовые (_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
Изменено: - 31.07.2023 15:01:53
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Интересует мнение постоянных помогающих — тех, за чей счёт форум вообще живёт. Как вы считаете - наличие тем приемлемо для сайта? Я — категорически против.
Изменено: - 13.06.2023 09:17:26
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
BedvitCOM. Предложения для библиотеки. Получить одномерные массивы из столбцов двумерного, Array_2Dto1D_Columns
Приветствую! Возникла необходимость в очередном инструменте. Аналог на существующих процедурах невероятно медленный (в 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
'==================================================================================================
Изменено: - 30.05.2023 13:40:15
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
BedvitCOM. Предложения для библиотеки. Фильтр массива (1D/2D) по Long-массиву индексов, ArrayFilter_ByArrIndexes
Приветствую! Тема создана в рамках инструмента , но посвящена самостоятельному инструменту.
Что делает инструмент: фильтрует (оставляет) в переданном стринговом массиве только те элементы, чьи индексы есть в переданном массиве индексов (он отсортирован/собран по возрастанию индексов). Дополнительная опция позволяет инвертировать фильтр, то есть убрать элементы с переданными индексами.
Нужна процедура в библе на сях, позволяющая делать тоже самое, что и вариант ниже на 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
'==================================================================================================
Изменено: - 22.05.2023 15:38:46
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
BedvitCOM. Предложения для библиотеки. Простой фильтр одномерного массива, Array1D.Filter
Реальная задача (из #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
UPD: 29/05/2023: —
Изменено: - 31.05.2023 13:24:51
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Получить все бинарные числа для заданного количества знаков, Get Binary values for target LenNum
Сочинил процедуру для быстрого получения всех бинарных (состоящих только из цифр 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
'==================================================================================================
Изменено: - 25.05.2023 14:18:03
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
VBAшники не пишут макросы, Душный разбор некорректного (но повсеместного) использования термина
С недавних пор решил бороться с некорректным использованием термина "макрос". Начал с себя, а потом и в общении с заказчиками стал пояснять важную разницу. Итак, по , но своими словами: макрос (правильно говорить "макрокоманда") [здесь и далее будут подразумеваться макрокоманды в продуктах MS Office и подобные им] — это записанная последовательность действий пользователя. Из этого следует, что макросы пишет сама программа/приложение и никто другой. В MS Excel этим занимается специальная программа, которая так и называется — макрорекордер (MacroRecorder — "макрописец"). Никто другой и ничто другое макросы не пишет. Чисто технически, программист, конечно, может написать альтернативную программу, которая подключается к приложению (MS Excel, например) и "переводит" действия пользователя в программный код, но, как мы все тут понимаем, разговор, не об этом.
Вывод: программисты пишут программы, некоторые из которых пишут макрокоманды
Альтернативные термины (вместо "напишите мне макрос", говорим … ): • напишите мне код на VBA • напишите мне скрипт (не совсем корректно, но вполне допустимо) на VBA • создайте/напишите мне программу на VBA • автоматизируйте мне следующие процессы с помощью VBA
Изменено: - 14.03.2023 17:32:14
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Приветствую! Нужен аналог (более-менее похожий) для управления проектами типа - желательно, бесплатный и точно официальный (не кряк), для использования в компании. Данное ПО должно относится к категории "Scrum/Kanban-board", быть бесплатным, иметь WEB-версию и поддерживать совместную работу. Пока изучаю перечень.
Изменено: - 13.03.2023 17:58:51
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
Математика. Теория вероятностей. Менять ли выбор двери с призом при открытии очередной пустой, Сцена из фильма «21»
В сцене из аудитории на лекции задаётся вопрос (произвольная трактовка): если перед вами 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
Изменено: - 20.02.2023 16:01:49
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел)
.
, что ничего в старом описании было непонятно, поэтому напишу примерный ход разработки по порядку.
