я вам его не обещал, так что ждать, возможно, придётся долго С праздником и вас
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Евгений Смирнов: Недели две назад сравнивал работу, сейчас еще раз проверил. Никакой разницы нет в работе в трех вариантах записи Application.WorksheetFunction.Trim, WorksheetFunction.Trim, Application.Trim не нашел.
что не означает, что разницы нет. Лень искать (не так просто), но давно ещё вместе с ZVI обсуждали и тестировали.
Цитата
Евгений Смирнов: Во всех случаях получается функция рабочего листа
это не так
Цитата
Евгений Смирнов: Ведь эксель как то различает функцию Mid и оператор Mid, хотя у них 3 аргумента и все одинаковые.
очень просто — по положению. x = Mid(s, 1, 1)<>Mid(s, 1, 1) = x
Цитата
Евгений Смирнов: лучше писать полностью Application.WorksheetFunction.Trim
если нужна функция листа, то только её и нужно писать. Если работаете с разными приложениями (Applications), то, для однозначности можно указывать соответствующее, но не как Application, а как ApXl (Dim ApXl As New Excel.Application или как-то так)
Цитата
andypetr: По-моему, "WorksheetFunction." излишество, можно использовать "Application.":
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
разумеется, нет, но может запомнить значение из другого поля той же строки — например "выделено"
Цитата
Павел Савин: Прошу подсказать как автоматизировать транспонирование данных из Таблицы 1, чтобы она получила вид, как в Таблице 2.
никак, потому что …
… ВОТ транспонирование (обмен строк и столбцов местами)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Промежуточные тесты показывают, что за фильтром от BedVit'а мне не угнаться даже при "статичном подходе"
Учитывая новое удобство передачи критериев, огромные трудозатраты по организации "статичных" параметров и, конечно же, при всём этом, недостаточную для конкуренции скорость, я бы решал подобную задачу так: 1. Собираем все необходимые (присутствующие на листе или ещё как) комбинации параметров. Осуществляем это обновление по кнопке или событию. 2. Пропускаем их через фильтр из библы, запоминая в карту (по ключу комбинации) индексы строк или собирая значения сразу, как нужно. Осуществляем это обновление по кнопке или событию. Оно может быть как синхронизировано с п.1, так и нет (зависит от логики задачи). 3. Выгружаем на лист калькуляции где и когда это нужно. Если нужен вариант через функцию листа, то в функции просто извлекаем необходимое из карты и отображаем на листе.
В принципе, этого должно хватить для абсолютного большинства всех случаев. Как (и, если) понадобиться переосмыслить подход — вернусь к теме.
bedvit, ещё раз огромное спасибо за библу (в целом) и фильтр (в частности)!
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Павел Савин: как автоматизировать конвертацию данных из Таблицы 1, чтобы она получила вид, как в Таблице 2
VBA/PowerQuery. Гуглите по запросу "excel редизайнер" — в том числе и на этом сайте.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
смотря, как. Если можно функцию заменить на вставку вычислений, когда нужно, то одни плюсы и, в том числе, выше скорость. Если же функцию листа хочется сохранить то нужно сильнее заморочиться — можно для каждого диапазона хранить вычисления в ОЗУ и обновлять только по необходимости, а на лист быстро тянуть только готовый результат. Как тут. Но будет тоже очень быстро и практически не будет грузить пересчёты других формул листа. В любом случае, это история про словарь и его аналоги.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Теперь стало совсем хорошо — параметры для фильтра можно задавать понятной простой строкой со вспомогательным одномерным массивом для проверяемых при фильтрации значений. Демонстрацию оформил на примерах из предыдущего поста
Оцените краткость записи с сохранением её смысла и читаемости
Было
Стало
Особенно, старую процедуру ManualParams в сравнении с новой записью
Было
Стало
Описание
Для начала определимся с терминами: • строка запроса (sReq$) — текстовая команда пользователя, с помощью которой он задаёт параметры фильтрации.
• элементы запроса — элементы массива, полученные после обработки/нормализации строки запроса, сплита её по пробелу и приведения нижней границы к 1. То есть, после выполнения функции Prepare().
• тип элемента запроса — категория, в соответствии с 6ю полями двумерного массива, как основного источника информации о фильтрации для инструмента библы. Вот эти поля: 1.Logic, 2.Bracket(Left), 3.ColumnNumber, 4.ParamCondition, 5. ValueForCompare, 6.Bracket(Right). Скобки повторяются, поэтому типов на 1 меньше, чем полей — 5.
• блок условий — одна команда для фильтра. Состоит из полей: 3(ColNum), 4(ParamCond) и 5(ValForComp) — если брать по двумерному массиву для фильтра. Пример:Col5 Not Like "*[a-z]*"
• вспомогательный массив (a1D_ValForReq) — одномерный массив со значениями ValueForCompare (Col5 of Arr2D) для их подстановки по индексам этого массива (с 1) при разборе строки запроса. Сделано так, чтобы иметь возможность качественно и быстро проверить строку запроса на предмет ошибок, а также позволить пользователю некоторые вольности (для удобства) при составлении строки запроса без ущерба для качества проверки. Простой пример: строка нормализуется (часть алгоритма) путём добавления пробелов слева/справа от скобок + между цифрой и НЕцифрой. Потом пробелы между скобками удаляются. Полученная строка сплитуется по пробелу и мы получаем "чистые" элементы запроса. Если позволить вводить значения в строку запроса, ничего подобного вы сделать уже не сможете. Будет полная неразбериха. Решается это резервированием символов и использованием их в качестве разделителей, а также экранирования их реальных значений (как символ "<" в HTML, например). Очевидно, что сложность и время проверки/разбора такой строки, а также количество правил, которые пользователь должен учитывать — возрастают многократно.
Вместо массива можно задать значение. Оно будет преобразовано в одномерный массив от 1 "внутри" функции. Можно НЕ повторять в этом массиве одинаковые элементы и ссылаться сколько угодно раз на один и тот же индекс в строке запроса.
• индекс вспомогательного массива (IndOfArr&) — целое число (>= 1), которое используется в строе запроса ВМЕСТО значения. При разборе строки запроса, этот индекс будет заменён на соответствующее значение.
• параметры сравнения и символы-интерпретаторы — в библе, для задания условий используются целые числа: 0 и степени двойки (на данный момент, до 2 ^ 9 = 512). Условия можно разделить на 2 блока: логика ( Or (0), And(1) ) и методы (все остальные). В строке запроса, для того, чтобы пользователю было проще и для сокращения длины записи без потери качества, вместо этих чисел-параметров я использую первые буквы названий этих параметров, согласно моему определению в ENum или более понятные и привычные (VBAшнику) символы типа "<=>". Таким образом, чтобы записать "Not Like" достаточно "NL" (или "LN", т.к. порядок не имеет значения), "больше или равно" записывается как ">=", не равно — "<>" и так далее.
Теперь, после описания терминов, можно сказать, что строка условий состоит из блоков условий, объединяемых логическими операторами и скобками (для определения порядка выполнения операций сравнения).
Итак, сделал 3 функции: • BV_Filter_GetParams_ByStr() Основная функция. Позволяет задавать правила любой сложности. Шаблон:( ColNum ParCond IndOfArr ) Logic ( ColNum ParCond IndOfArr ) … Пример в виде псевдозапроса:(Col3 = 12) And (Col 5 <> "333") Тот же пример в виде реальной строки запроса:(3=1) A (5<>2). Where 1 is 12 and 2 is "333" because a1D_ValForReq = Array(12, "333")
Скобок может быть больше — в зависимости от логики (в примере их несколько), но, для этой функции, скобки (хотя бы по одной открывающей и закрывающей) должны быть для каждого блока условий. Сделано это, поскольку, подразумевается, что для разных логических операторов нужно однозначно скобками указать порядок операций. Для одинаковых логических операторов есть следующая функция.
• BV_Filter_GetParams_ByStr_OneLogic() Облегчённая функция. Позволяет задавать правила для одинаковых логических операторов. Шаблон:ColNum ParCond IndOfArr ColNum ParCond IndOfArr … Пример в виде псевдозапроса:Col3 = 12 Col 5 <> "333"
• BV_Filter_GetParams_ByStr_OneLogic_OneCol() Самая "лёгкая" функция. Позволяет задавать правила для одинаковых логических операторов и одного и того же столбца. Шаблон:ParCond IndOfArr ParCond IndOfArr … Пример в виде псевдозапроса:Like "*A*" Not Like "*B*"
Надёжность очень высокая — присутствует огромное количество проверок входящих данных и возможность вывода сообщения на любом этапе. Напортачить, конечно, можно, но надо постараться и/или не понимать, что ты делаешь.
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public BV As New BedvitCOM.VBA
'==================================================================================================
Sub TestFilter()
Dim x, aT, aP, aL, s$
' Get Arr2D of Table ------------------------
aT = ActiveSheet.ListObjects(1).DataBodyRange.Value2
' Choose ONE(out of 6) Variant --------------
' 1. Col5 is NOT Equal "1U rack" (Col5 is Equal "2U rack" because there are only 2 Values in Col5)
If Not BV_Filter_GetParams_ByStr_OneLogic(aP, "5<>1", "1U rack", , , True) Then Stop: End
' 2. Col2 have "e" AND Col2 have "n". Intel,Lenovo.
If Not BV_Filter_GetParams_ByStr_OneLogic_OneCol(aP, "i1 i2", Array("e", "n"), False, 2, , True) Then Stop: End
' 3. Col2 have "d/D" OR Col2 have "i/I"(CaseIgnore). Dell,Intel.
If Not BV_Filter_GetParams_ByStr_OneLogic_OneCol(aP, "ic1 ic2", Array("D", "I"), True, 2, , True) Then Stop: End
' 4. Col2 = "Dell" AND Col4 Like "LGA ####".
If Not BV_Filter_GetParams_ByStr_OneLogic(aP, "2=1 4L2", Array("Dell", "LGA ####"), False, , True) Then Stop: End
' 5. Col2 = "HPE" OR Col4 Like "LGA 1*".
If Not BV_Filter_GetParams_ByStr_OneLogic(aP, "2=1 4L2", Array("HPE", "LGA 1*"), True, , True) Then Stop: End
' 6. ( Col2 = "Dell" And Col4 Like "LGA 1*" ) Or ( Col2 = "HPE" And Col5 Not Like "2*" )
x = Array("Dell", "LGA 1*", "HPE", "2*")
s = "((2=1) A (4L2)) O ((2=3) A (5NL4))"
If Not BV_Filter_GetParams_ByStr(aP, s, x, , True) Then Stop: End
' Filter ------------------------------------
If (BV_Filter_Run(aT, aP, aL, , True, True) <> 1) Then Exit Sub ' Include Msgs if not Full
' Load on Sheet -----------------------------
[N2:R200].ClearContents
[N2].Resize(UBound(aL, 1), UBound(aL, 2)).Value2 = aL
MsgBox "Load Rows: " & Format$(UBound(aL, 1), "#,#") & " out of " & Format$(UBound(aT, 1), "#,#"), vbInformation, "DONE"
End Sub
'==================================================================================================
Модуль «BV_Work_Filter»
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Enum e_BV_Filt_Logic
Or_ = 0 ' O(79)
And_ = 1 ' A(65)
End Enum
'==================================================================================================
Enum e_BV_Filt_Oper
Less = 1 ' <(60) Min
Equal = 2 ' =(61)
More = 4 ' >(62)
InStr_ = 8 ' I(73)
RegExp = 16 ' R(82) Max
CaseIgnore = 32 ' C(67)
Basic = 64 '
Extended = 128 '
Like_ = 256 ' L(76)
Not_ = 512 ' N(78)
End Enum
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Function IsIntPosit(ByVal vIn, vIntOut, Optional AllowZero As Boolean) As Boolean
If Not IsNumeric(vIn) Then Exit Function
vIn = --vIn
If (vIn <> Fix(vIn)) Then Exit Function
If AllowZero Then
If (vIn < 0) Then Exit Function
Else
If (vIn < 1) Then Exit Function
End If
vIntOut = vIn: IsIntPosit = True
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Function ReqFix(sIn$, sOutIn$, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, i&
Static st&, REa As RegExp, REl As RegExp, REr As RegExp, REd As RegExp
If (st = 0) Then
st = 1
Set REa = New RegExp: REa.Global = True: REa.Pattern = "([()])"
Set REl = New RegExp: REl.Global = True: REl.Pattern = "(\d)(\D)"
Set REr = New RegExp: REr.Global = True: REr.Pattern = "(\D)(\d)"
Set REd = New RegExp: REd.Global = True: REd.Pattern = "([()]) ([()])"
End If
s = UCase$(BV.Trim(sIn))
If (s Like "*[! ()0-9<=>ACILNOR]*") Then
If MsgFalse Then MsgBox "RequestString" & vbLf & "«" & sIn & "»" & vbLf & vbLf & "contain BAD Symbol!", vbCritical, "BV_Filter_GetParams(ReqFix)"
Exit Function
End If
Do
i = InStr(s, "<>"): If (i = 0) Then Exit Do
Mid$(s, i, 2) = "N="
Loop
s = REa.Replace$(s, " $1 ")
s = REl.Replace$(s, "$1 $2")
s = REr.Replace$(s, "$1 $2")
s = BV.Trim(s)
s = REd.Replace$(s, "$1$2")
If MsgTrue Then MsgBox "RequestString" & vbLf & "«" & sIn & "»" & vbLf & vbLf & "was succsessfully transformed to" & vbLf & "«" & s & "»", vbInformation, "BV_Filter_GetParams(ReqFix)"
ReqFix = True: sOutIn = s
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_ReqFix()
Dim s$
s = "( (2=>1)a(4l2) )o( (2<=3)a(5nl4) )"
ReqFix s, s, True, True ' «(( 2 => 1 ) A ( 4 L 2 )) O (( 2 <= 3 ) A ( 5 NL 4 ))»
End Sub
'==================================================================================================
'==================================================================================================
Private Function UnCode(sIn$, vOut&, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&, c&, p&
Static st&, a&()
If (st = 0) Then
st = 1: ReDim a(82)
For n = 1 To UBound(a)
a(n) = -1
Next n
a(60) = 1 ' <
a(61) = 2 ' =
a(62) = 4 ' >
a(65) = 1 ' A: And(Logic)
a(67) = 32 ' C: CaseIgnore
a(73) = 8 ' I: InStr
a(76) = 256 ' L: Like
a(78) = 512 ' N: Not
a(79) = 0 ' O: Or(Logic)
a(82) = 16 ' R: RegExp
End If
If (sIn = "") Then
If MsgFalse Then MsgBox "Code is EMPTY!", vbCritical, "BV_Filter_GetParams(UnCode)"
Exit Function
End If
vOut = 0: p = -1
On Error Resume Next
For n = 1 To Len(sIn)
c = BV.UnicodeCharCodeGet(sIn, n): p = a(c)
If (p = -1) Then
If MsgFalse Then MsgBox "Char «" & ChrW$(c) & "» is NOT Correct!", vbCritical, "BV_Filter_GetParams(UnCode)"
Exit Function
End If
vOut = vOut + p: p = -1
Next n
UnCode = True
If MsgTrue Then MsgBox "Code «" & sIn & "» is Correct and calculate to number «" & vOut & "»", vbInformation, "BV_Filter_GetParams(UnCode)"
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_UnCode()
Dim n&
UnCode "NL", n, True, True
End Sub
'==================================================================================================
'==================================================================================================
' Checks
'==================================================================================================
Private Function Ch1_Logic(aReq, nPos&, vOut, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&
s = aReq(nPos): If Not UnCode(s, n, , MsgFalse) Then GoTo er
If ((n <> 0) And (n <> 1)) Then GoTo er
If MsgTrue Then MsgBox "Argument «sReq» contain Correct Logic «" & s & "(" & n & ")»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch1_Logic)"
vOut = n: Ch1_Logic = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD Logic «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch1_Logic)"
End Function
'==================================================================================================
Private Function Ch2_Brackets(aReq, nPos&, vOut, Optional RightBracket As Boolean, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$
s = aReq(nPos)
If RightBracket Then
If (s Like "*[!)]*") Then GoTo er
Else
If (s Like "*[!(]*") Then GoTo er
End If
If MsgTrue Then MsgBox "Argument «sReq» contain Correct Bracket(s) «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch2_Brackets)"
vOut = s: Ch2_Brackets = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD Bracket(s) «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch2_Brackets)"
End Function
'==================================================================================================
Private Function Ch3_ColNum(aReq, nPos&, vOut, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&
s = aReq(nPos): If Not IsIntPosit(s, n) Then GoTo er
If MsgTrue Then MsgBox "Argument «sReq» contain Correct ColNum «" & n & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch3_ColNum)"
vOut = n: Ch3_ColNum = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD ColNum «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch3_ColNum)"
End Function
'==================================================================================================
Private Function Ch4_ParamCode(aReq, nPos&, vOut, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&
s = aReq(nPos): If Not UnCode(s, n, , MsgFalse) Then GoTo er
If MsgTrue Then MsgBox "Argument «sReq» contain Correct CodeParam «" & s & "(" & n & ")»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch4_ParamCode)"
vOut = n: Ch4_ParamCode = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD CodeParam «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch4_ParamCode)"
End Function
'==================================================================================================
Private Function Ch5_ArrIndex(aReq, nPos&, vOut, aVal, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim s$, n&, UBnd&
s = aReq(nPos): If Not IsIntPosit(s, n) Then GoTo er
UBnd = UBound(aVal): If (n > UBnd) Then GoTo er
If MsgTrue Then MsgBox "Argument «sReq» contain Correct ArrIndex «" & n & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbInformation, "BV_Filter_GetParams_ByStr(Ch5_ArrIndex)"
vOut = aVal(n): Ch5_ArrIndex = True: Exit Function
er: If MsgFalse Then MsgBox "Argument «sReq» contain BAD ArrIndex «" & s & "»" & vbLf & vbLf & "«" & Join(aReq) & "»", vbCritical, "BV_Filter_GetParams_ByStr(Ch5_ArrIndex)"
End Function
'==================================================================================================
'==================================================================================================
' Prepare
'==================================================================================================
Private Function Prepare(sReq_InOut$, aSpl_Out, DivBy236&, a1D_ValForReq, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
If Not ReqFix(sReq_InOut, sReq_InOut, , MsgFalse) Then Exit Function
If (DivBy236 = 6) Then sReq_InOut = "A " & sReq_InOut
aSpl_Out = Split(sReq_InOut): BV.ArrayReDim aSpl_Out, 1
If ((UBound(aSpl_Out) Mod DivBy236) <> 0) Then
If MsgFalse Then MsgBox "Argument «sReq» is NOT Divisible by " & DivBy236 & "!" & vbLf & "«" & sReq_InOut & "»", vbCritical, "BV_Filter_GetParams_ByStr(Prepare)"
Exit Function
End If
If Not IsArray(a1D_ValForReq) Then a1D_ValForReq = Array(a1D_ValForReq)
BV.ArrayReDim a1D_ValForReq, 1
Prepare = True
If MsgTrue Then MsgBox "Argument «sReq» was successfully Prepared" & vbLf & vbLf & "«" & sReq_InOut & "»", vbInformation, "BV_Filter_GetParams_ByStr(Prepare)"
End Function
'==================================================================================================
'==================================================================================================
' GetParams_ByStr
'==================================================================================================
' Rule: (Col2 = "Dell" And Col4 Like "LGA 1*") Or (Col2 = "HPE" And Col5 Not Like "2*")
' Tens: 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 2 2 2 2 Total: 23 + 1 = 24. 24 Mod 6 = 0. 24 / 6 = 4 Rows in a2D_Par_Out
' Units: 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3
' sReq(Perfect): "(( 2 = 1 ) A ( 4 L 2 )) O (( 2 = 3 ) A ( 5 NL 4 ))"
' sReq(can be): "( (2=1)a(4l2) )o( (2=3)a(5nl4) )"
' a1D_ValForReq: Array("Dell", "LGA 1*", "HPE", "2*")
' Tens: 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 Total: 24
' Units: 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4
' sReq(transform): "A (( 2 => 1 ) A ( 4 L 2 )) O (( 2 <= 3 ) A ( 5 NL 4 ))"
Function BV_Filter_GetParams_ByStr(a2D_Par_Out, ByVal sReq$, ByVal a1D_ValForReq, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim x, spl, s$, r&, n&, p&, UBnd&
If Not Prepare(sReq, spl, 6, a1D_ValForReq, , MsgFalse) Then Exit Function
ReDim a2D_Par_Out(UBound(spl) / 6, 6)
For r = 1 To UBound(a2D_Par_Out, 1)
If Not Ch1_Logic(spl, n + 1, a2D_Par_Out(r, 1), , MsgFalse) Then Exit Function
If Not Ch2_Brackets(spl, n + 2, a2D_Par_Out(r, 2), False, , MsgFalse) Then Exit Function
If Not Ch3_ColNum(spl, n + 3, a2D_Par_Out(r, 3), , MsgFalse) Then Exit Function
If Not Ch4_ParamCode(spl, n + 4, a2D_Par_Out(r, 4), , MsgFalse) Then Exit Function
If Not Ch5_ArrIndex(spl, n + 5, a2D_Par_Out(r, 5), a1D_ValForReq, , MsgFalse) Then Exit Function
If Not Ch2_Brackets(spl, n + 6, a2D_Par_Out(r, 6), True, , MsgFalse) Then Exit Function
n = n + 6
Next r
BV_Filter_GetParams_ByStr = True
If MsgTrue Then MsgBox "2D-Array (Rows: " & Format$(UBound(a2D_Par_Out, 1), "#,#") & ") with Parameters for BV.ArrayFilterV was successfully created!", vbInformation, "BV_Filter_GetParams_ByStr"
End Function
'--------------------------------------------------------------------------------------------------
' Rule: ( (Col2 = "Dell") And (Col4 Like "LGA 1*") ) Or ( (Col2 = "HPE") And (Col5 Not Like "2*") )
Private Sub Test_BV_Filter_GetParams_ByStr()
Dim a, s$
s = "( (2=1)a(4l2) )o( (2=3)a(5nl4) )"
a = Array("Dell", "LGA 1*", "HPE", "2*")
If Not BV_Filter_GetParams_ByStr(a, s, a, True, True) Then Exit Sub
Worksheets.add After:=ActiveSheet
[a1].Value2 = s
[a4].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
a = Array("Logic", "(", "ColNum", "CodeParam", "Value", ")")
[A3].Resize(1, UBound(a)).Value2 = a
End Sub
'==================================================================================================
'==================================================================================================
' Rule: Col2 = "Dell" And Col4 Like "LGA 1*"
' sReq(Perfect): "2 = 1 4 L 2" ' Must be Divisible by 3
' sReq(can be): "2=1 4L2"
Function BV_Filter_GetParams_ByStr_OneLogic(a2D_Par_Out, ByVal sReq$, ByVal a1D_ValForReq, Optional UseOR As Boolean, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim spl, s$, r&, n&, logic&
If Not Prepare(sReq, spl, 3, a1D_ValForReq, , MsgFalse) Then Exit Function
If Not UseOR Then logic = 1 ' 0 is Or, 1 is And (As Default)
ReDim a2D_Par_Out(UBound(spl) / 3, 6)
For r = 1 To UBound(a2D_Par_Out, 1)
a2D_Par_Out(r, 1) = logic
a2D_Par_Out(r, 2) = "("
If Not Ch3_ColNum(spl, n + 1, a2D_Par_Out(r, 3), , MsgFalse) Then Exit Function
If Not Ch4_ParamCode(spl, n + 2, a2D_Par_Out(r, 4), , MsgFalse) Then Exit Function
If Not Ch5_ArrIndex(spl, n + 3, a2D_Par_Out(r, 5), a1D_ValForReq, , MsgFalse) Then Exit Function
a2D_Par_Out(r, 6) = ")"
n = n + 3
Next r
BV_Filter_GetParams_ByStr_OneLogic = True
If MsgTrue Then MsgBox "2D-Array (Rows: " & Format$(UBound(a2D_Par_Out, 1), "#,#") & ") with Parameters for BV.ArrayFilterV was successfully created!", vbInformation, "BV_Filter_GetParams_ByStr_OneLogic"
End Function
'--------------------------------------------------------------------------------------------------
' Rule: Col2 = "Dell" And Col4 Like "LGA 1*"
Private Sub Test_BV_Filter_GetParams_ByStr_OneLogic()
Dim a, s$
s = "2=1 4L2"
a = Array("Dell", "LGA 1*")
If Not BV_Filter_GetParams_ByStr_OneLogic(a, s, a, , True, True) Then Exit Sub
Worksheets.add After:=ActiveSheet
[a1].Value2 = s
[a4].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
a = Array("Logic", "(", "ColNum", "CodeParam", "Value", ")")
[A3].Resize(1, UBound(a)).Value2 = a
End Sub
'==================================================================================================
'==================================================================================================
' Rule: Col2 = "Dell" And Col2 Like "LGA 1*"
' sReq(Perfect): "= 1 L 2" ' Must be Divisible by 2
' sReq(can be): "=1 L2"
Function BV_Filter_GetParams_ByStr_OneLogic_OneCol(a2D_Par_Out, ByVal sReq$, ByVal a1D_ValForReq, Optional UseOR As Boolean, Optional ColNum& = 1, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim spl, s$, r&, n&, logic&
If Not Prepare(sReq, spl, 2, a1D_ValForReq, , MsgFalse) Then Exit Function
If Not UseOR Then logic = 1 ' 0 is Or, 1 is And (As Default)
ReDim a2D_Par_Out(UBound(spl) / 2, 6)
For r = 1 To UBound(a2D_Par_Out, 1)
a2D_Par_Out(r, 1) = logic
a2D_Par_Out(r, 2) = "("
a2D_Par_Out(r, 3) = ColNum
If Not Ch4_ParamCode(spl, n + 1, a2D_Par_Out(r, 4), , MsgFalse) Then Exit Function
If Not Ch5_ArrIndex(spl, n + 2, a2D_Par_Out(r, 5), a1D_ValForReq, , MsgFalse) Then Exit Function
a2D_Par_Out(r, 6) = ")"
n = n + 2
Next r
BV_Filter_GetParams_ByStr_OneLogic_OneCol = True
If MsgTrue Then MsgBox "2D-Array (Rows: " & Format$(UBound(a2D_Par_Out, 1), "#,#") & ") with Parameters for BV.ArrayFilterV was successfully created!", vbInformation, "BV_Filter_GetParams_ByStr_OneLogic_OneCol"
End Function
'--------------------------------------------------------------------------------------------------
' Rule: Col2 = "Dell" And Col2 Like "LGA 1*"
Private Sub Test_BV_Filter_GetParams_ByStr_OneLogic_OneCol()
Dim a, s$
s = "=1 L2"
a = Array("Dell", "LGA 1*")
If Not BV_Filter_GetParams_ByStr_OneLogic_OneCol(a, s, a, , 2, True, True) Then Exit Sub
Worksheets.add After:=ActiveSheet
[a1].Value2 = "'" & s
[a4].Resize(UBound(a, 1), UBound(a, 2)).Value2 = a
a = Array("Logic", "(", "ColNum", "CodeParam", "Value", ")")
[A3].Resize(1, UBound(a)).Value2 = a
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function BV_Filter_Run(aFilt_In, aParam_In, aOutIn, Optional RetIndexes As Boolean, Optional Msg–1_Err As Boolean, Optional Msg0_Empty As Boolean, Optional Msg1_Full As Boolean) As Long
Dim rOld&, rNew&
rOld = UBound(aFilt_In, 1) - LBound(aFilt_In, 1) + 1
On Error Resume Next
BV.ArrayFilterV aFilt_In, aParam_In, RetIndexes, aOutIn
If (Err.Number <> 0) Then
If Msg–1_Err Then MsgBox "UnCorrect condition(s)!", vbCritical, "BV_Filter_Run"
Err.Clear: BV_Filter_Run = -1: Exit Function
End If
rNew = UBound(aOutIn, 1) - LBound(aOutIn, 1) + 1
If (rNew < 1) Then
If Msg0_Empty Then MsgBox "Can't Find any Row!", vbExclamation, "BV_Filter_Run"
Exit Function
End If
BV_Filter_Run = 1
If Msg1_Full Then MsgBox "Filter Rows: " & Format$(rNew, "#,#") & " out of " & Format$(rOld, "#,#"), vbInformation, "BV_Filter_Run"
End Function
'==================================================================================================
«Вот теперь тебя люблю я …» К. И. Чуковский. «Мойдодыр»
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
отнюдь. Можно ещё макрофункцию написать, оформить в надстройку (в которой вообще очень много чего можно хранить) и "распространить среди жильцов нашего ЖЭКа"
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
AlexGor: Или знающему человеку проще делать с ноля, чем капаться в моих изысканиях?
да Коллекции легко заменяются на словари, если нужно что-то искть/агрегировать по ключу. Приготовьте файл-пример с частью исходной таблицы и вариантами нужных расчётов
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
По просьбе mik94 и за символическую оплату сделал такую версию (написана с нуля) функции:
Описание
Очень шустрая функция. Можно использовать как на листе, так и в VBA. Принимает начало и окончание рабочего дня (целые числа в часах), а также дату-время начала и окончания работы. Возвращает количество рабочих часов между 2мя переданными датами. Если начало работы раньше начала рабочего дня, то за начало работы принимается начало рабочего дня. Если окончание работы позже окончания рабочего дня, то за окончание работы принимается окончание рабочего дня. Если дата-время начала работы позже её окончания, то функция меняет их местами при расчётах.
Для того, чтобы праздники не учитывались при вычислении часов работы, в книге должен быть именованный диапазон WH_Holidays. Кроме дат, указанных в этом диапазоне (или при его отсутствии) все дни считаются рабочими.
!!! ВАЖНОЕ по праздникам !!!
Из диапазона будут взяты только РЕАЛЬНЫЕ даты (целое или дробное число в формате типа "дата" или "дата-время") не равные 0 (если задать общий формат). Все ошибки, пустые, текст и прочее будет игнорироваться. Диапазон должен состоять из одной области. Если будет несколько, то примется в расчёт только первая. Можно обойти, но не вижу смысла так задавать перечень. Диапазон может состоять из одной ячейки. Такой диапазон может быть только один на книгу/файл. Все вхождения функции на листе будут работать с этим одним диапазоном. Так функция будет работать многократно быстрее, нежели позволить указывать для каждого вхождения функции свой диапазон праздников. Вы всегда можете сделать копию файла и в ней задать другие праздники. Изменения в этом диапазоне функция увидит только при сбросе переменных, хранящихся в памяти. Программист знает, как сбросить руками, а обычному пользователю достаточно знать, что это произойдёт при закрытии книги/файла. То есть, в общем случае, чтобы обновить праздники, нужно переоткрыть книгу. Чтобы это обойти, я добавил в функцию дополнительное условие и данные обновляются при УХОДЕ с листа с праздниками (флаг + полный пересчёт).
Option Base 1
Option Explicit
'Option Private Module
'==================================================================================================
Public WH_ReCalc As Boolean
'==================================================================================================
Function WorkHours(HourBeg&, HourEnd&, ByVal DT_Beg As Date, ByVal DT_End As Date) As Double
Dim rng As Range
Dim x, arr, f As Boolean
Dim hB#, hE#, fB&, fE&, h&, u&, n&, v&
Static st&, aHol() As Byte, HolMin&, HolMax&, fHol As Boolean
If (st = 1) Then If WH_ReCalc Then st = 0: WH_ReCalc = False
If (st = 0) Then
st = 1
HolMax = 0: HolMin = 1000000000: fHol = False
On Error Resume Next
Set rng = Range("WH_Holidays") ' One Area
On Error GoTo 0: If (rng Is Nothing) Then GoTo nx
u = Fix(Now) + 1000: ReDim aHol(u)
arr = rng.Value: If Not IsArray(arr) Then arr = Array(arr)
For Each x In arr
If (VarType(x) <> vbDate) Then GoTo nxX
If (Val(x) = 0) Then GoTo nxX
n = Fix(x): fHol = True
If (n > HolMax) Then HolMax = n
If (n < HolMin) Then HolMin = n
If (n > u) Then u = 2 * n: ReDim Preserve aHol(u)
aHol(n) = 1
nxX: Next x
If fHol Then ReDim Preserve aHol(HolMax)
End If
nx:
If (DT_Beg > DT_End) Then hB = DT_Beg: DT_Beg = DT_End: DT_End = hB
fB = Fix(DT_Beg): fE = Fix(DT_End)
hB = 24 * (DT_Beg - fB): If (hB < HourBeg) Then hB = HourBeg
hE = 24 * (DT_End - fE): If (hE > HourEnd) Then hE = HourEnd
h = HourEnd - HourBeg: n = 0: v = 0
If fHol Then f = Not ((fB > HolMax) Or (fE < HolMin))
If f Then
On Error Resume Next
v = aHol(fB)
If (fB = fE) Then ' OneDay
If (v = 1) Then Exit Function
hB = hE - hB: hE = 0
Else
If (v = 1) Then
v = 0: hB = 0
Else
hB = HourEnd - hB: If (hB < 0) Then hB = 0
End If
v = aHol(fE)
If (v = 1) Then
v = 0: hE = 0
Else
hE = hE - HourBeg: If (hE < 0) Then hE = 0
End If
End If
For u = fB + 1 To fE - 1
v = aHol(u)
If (v = 1) Then v = 0 Else n = n + 1
Next u
On Error GoTo 0
Else
hB = HourEnd - hB: If (hB < 0) Then hB = 0
hE = hE - HourBeg: If (hE < 0) Then hE = 0
n = fE - fB - 1
End If
WorkHours = h * n + hB + hE
End Function
'==================================================================================================
Private Sub Test_WorkHours()
Debug.Print WorkHours([b1], [b2], [a13], [b13])
End Sub
'==================================================================================================
Модуль листа праздников
Код
Option Base 1
Option Explicit
'Option Private Module
'==================================================================================================
Private Sub Worksheet_Deactivate()
WH_ReCalc = True
Application.CalculateFullRebuild
End Sub
'==================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Sanja, согласен, не заметил (но как же тупо написано). john22255, прошу прощения. Однако, вам объяснять очень долго, т.к. вы азов не понимаете. Пишете .ColorIndex, а ищете .Color. Поиграйтесь с цветами (присваивайте цвет и считывайте его) и этими 2мя методами. Так хоть есть надежда, что поймёте …
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
john22255: получаю цвет ярлычка таким образом MsgBox ActiveSheet.Tab.Color
показывает 65535.но по условию не срабатывает If Sheets(b).Tab.ColorIndex = 65535 Then
не могу понять почему
вам бы читать для начала научиться. В #2 ещё вам указали на ошибку логики.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
там вообще 2 часа будет, потому что 5е это воскресенье и учитывается только понедельник с 10 до 12
Цитата
mik94: Я думал, что Ваш макрос можно использовать для подсчета SLA (времени выполнения задачи по договору)
могу сделать вам под задачу — на коммерческой основе
Цитата
mik94: При такой постановке вопроса можно просто посчитать число дней и умножить на длительность одного дня
так вы не учтёте праздники(выходные в будни) и выходы (рабочие в выходные)
Очевидно, невозможно сделать функцию одну для всех задач или пользователи просто с ума сойдут (и не будут) разбираться с инструкцией к ней. Я постарался обобщить основное и взял инструмент PLEX за основу. Ну и расширенная версия ещё есть.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Итак, продолжаю популяризировать библу Написал несколько вспомогательных функций для работы с фильтром — стало куда проще (лично мне, во всяком случае). Функции упрощают запуск самого фильтра, делая его информативным (чем всё закончилось), а также упрощают создание массива параметров для одинаковой логики (везде Or или And) и одного столбца (другая функция, включающая одинаковую логику).
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public BV As New BedvitCOM.VBA
'==================================================================================================
Enum e_BV_Filt_Logic
Or_ = 0
And_ = 1
End Enum
'==================================================================================================
Enum e_BV_Filt_Oper
Less = 1
Equal = 2
More = 4
InStr_ = 8
RegExp = 16
CaseIgnore = 32
Basic = 64
Extended = 128
Like_ = 256
Not_ = 512
End Enum
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function BV_Filter_GetParams(aPar_Out, aColOperVal, Optional UseOR As Boolean, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim n&, r&, logic&
If Not IsArray(aColOperVal) Then
If MsgFalse Then MsgBox "Argument «aColOperVal» is NOT Array!", vbCritical, "BV_Filter_GetParams"
Exit Function
End If
BV.ArrayReDim aColOperVal, 1 ' Set LBound to 1
n = UBound(aColOperVal) ' Count of Elements
If ((n Mod 3) <> 0) Then
If MsgFalse Then MsgBox "«aColOperVal» is NOT Divisible by 3!", vbCritical, "BV_Filter_GetParams"
Exit Function
End If
If Not UseOR Then logic = 1 ' 0 is Or, 1 is And (As Default)
ReDim aPar_Out(n / 3, 6)
For n = 1 To n Step 3
r = r + 1
aPar_Out(r, 1) = logic
aPar_Out(r, 2) = "("
aPar_Out(r, 3) = aColOperVal(n)
aPar_Out(r, 4) = aColOperVal(n + 1) ' e_BV_FiltParam
aPar_Out(r, 5) = aColOperVal(n + 2) ' Value
aPar_Out(r, 6) = ")"
Next n
If MsgTrue Then MsgBox "2D-Array (Rows: " & Format$(r, "#,#") & ") with Parameters for BV.ArrayFilterV was successfully created!", vbInformation, "BV_Filter_GetParams"
BV_Filter_GetParams = True
End Function
'==================================================================================================
Function BV_Filter_GetParams_OneCol(aPar_Out, aOperVal, Optional nCol& = 1, Optional UseOR As Boolean, Optional MsgTrue As Boolean, Optional MsgFalse As Boolean) As Boolean
Dim n&, r&, logic&
If Not IsArray(aOperVal) Then
If MsgFalse Then MsgBox "Argument «aOperVal» is NOT Array!", vbCritical, "BV_Filter_GetParams_OneCol"
Exit Function
End If
BV.ArrayReDim aOperVal, 1 ' Set LBound to 1
n = UBound(aOperVal) ' Count of Elements
If ((n Mod 2) <> 0) Then
If MsgFalse Then MsgBox "«aOperVal» is NOT Divisible by 2!", vbCritical, "BV_Filter_GetParams_OneCol"
Exit Function
End If
If Not UseOR Then logic = 1 ' 0 is Or, 1 is And (As Default)
ReDim aPar_Out(n / 2, 6)
For n = 1 To n Step 2
r = r + 1
aPar_Out(r, 1) = logic
aPar_Out(r, 2) = "("
aPar_Out(r, 3) = nCol
aPar_Out(r, 4) = aOperVal(n) ' e_BV_FiltParam
aPar_Out(r, 5) = aOperVal(n + 1) ' Value
aPar_Out(r, 6) = ")"
Next n
If MsgTrue Then MsgBox "2D-Array (Rows: " & Format$(r, "#,#") & ") with Parameters for BV.ArrayFilterV was successfully created!", vbInformation, "BV_Filter_GetParams_OneCol"
BV_Filter_GetParams_OneCol = True
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function BV_Filter_Run(aFilt_In, aParam_In, aOutIn, Optional RetIndexes As Boolean, Optional Msg–1_Err As Boolean, Optional Msg0_Empty As Boolean, Optional Msg1_Full As Boolean) As Long
Dim rOld&, rNew&
rOld = UBound(aFilt_In, 1) - LBound(aFilt_In, 1) + 1
On Error Resume Next
BV.ArrayFilterV aFilt_In, aParam_In, RetIndexes, aOutIn
If (Err.Number <> 0) Then
If Msg–1_Err Then MsgBox "UnCorrect condition(s)!", vbCritical, "BV_Filter_Run"
Err.Clear: BV_Filter_Run = -1: Exit Function
End If
rNew = UBound(aOutIn, 1) - LBound(aOutIn, 1) + 1
If (rNew < 1) Then
If Msg0_Empty Then MsgBox "Can't Find any Row!", vbExclamation, "BV_Filter_Run"
Exit Function
End If
BV_Filter_Run = 1
If Msg1_Full Then MsgBox "Filter Rows: " & Format$(rNew, "#,#") & " out of " & Format$(rOld, "#,#"), vbInformation, "BV_Filter_Run"
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
'==================================================================================================
'==================================================================================================
Модуль «Example»
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub ManualParams(aParOut)
' 1 2 3 4
ReDim aParOut(4, 6) ' Rule: ( (Col2 = "Dell") And (Col4 Like "LGA 1*") ) Or ( (Col2 = "HPE") And (Col5 Not Like "2*") )
aParOut(1, 1) = "ANYTHING" ' 1st Logic will be cleared automatic in library(COM)
aParOut(1, 2) = "(("
aParOut(1, 3) = 2
aParOut(1, 4) = e_BV_Filt_Oper.Equal
aParOut(1, 5) = "Dell"
aParOut(1, 6) = ")"
aParOut(2, 1) = e_BV_Filt_Logic.And_
aParOut(2, 2) = "("
aParOut(2, 3) = 4
aParOut(2, 4) = e_BV_Filt_Oper.Like_
aParOut(2, 5) = "LGA 1*"
aParOut(2, 6) = "))"
aParOut(3, 1) = e_BV_Filt_Logic.Or_
aParOut(3, 2) = "(("
aParOut(3, 3) = 2
aParOut(3, 4) = e_BV_Filt_Oper.Equal
aParOut(3, 5) = "HPE"
aParOut(3, 6) = ")"
aParOut(4, 1) = e_BV_Filt_Logic.And_
aParOut(4, 2) = "("
aParOut(4, 3) = 5
aParOut(4, 4) = e_BV_Filt_Oper.Like_ + e_BV_Filt_Oper.Not_
aParOut(4, 5) = "2*"
aParOut(4, 6) = "))"
End Sub
'==================================================================================================
Sub TestFilter()
Dim x, aT, aP, aL, t!
aT = ActiveSheet.ListObjects(1).DataBodyRange.Value2
t = Timer
' Choose ONE(out of 6) Variant --------------
aP = Array(5, e_BV_Filt_Oper.Equal + e_BV_Filt_Oper.Not_, "1U rack") ' 1. Col5 is NOT Equal "1U rack" (Col5 is Equal "2U rack" because there are only 2 Values in Col5)
x = Array(e_BV_Filt_Oper.InStr_, "e", e_BV_Filt_Oper.InStr_, "n")
If Not BV_Filter_GetParams_OneCol(aP, x, 2, False, , True) Then Exit Sub ' 2. Col2 have "e" AND Col2 have "n". Intel,Lenovo.
x = Array(e_BV_Filt_Oper.InStr_ + e_BV_Filt_Oper.CaseIgnore, "d", e_BV_Filt_Oper.InStr_ + e_BV_Filt_Oper.CaseIgnore, "i")
If Not BV_Filter_GetParams_OneCol(aP, x, 2, True, , True) Then Exit Sub ' 3. Col2 have "d/D" OR Col2 have "i/I"(CaseIgnore). Dell,Intel.
x = Array(2, e_BV_Filt_Oper.Equal, "Dell", 4, e_BV_Filt_Oper.Like_, "LGA ####")
If Not BV_Filter_GetParams(aP, x, False, , True) Then Exit Sub ' 4. Col2 = "Dell" AND Col4 Like "LGA ####".
x = Array(2, e_BV_Filt_Oper.Equal, "HPE", 4, e_BV_Filt_Oper.Like_, "LGA 1*")
If Not BV_Filter_GetParams(aP, x, True, , True) Then Exit Sub ' 5. Col2 = "HPE" OR Col4 Like "LGA 1*".
ManualParams aP ' 6. Manual Params
' Filter ------------------------------------
If (BV_Filter_Run(aT, aP, aL, , True, True) <> 1) Then Exit Sub ' Include Msgs if not Full
t = Timer - t
' Load on Sheet ---------------------------------
[N2:R200].ClearContents
[N2].Resize(UBound(aL, 1), UBound(aL, 2)).Value2 = aL
MsgBox "Load Rows: " & Format$(UBound(aL, 1), "#,#") & " out of " & Format$(UBound(aT, 1), "#,#"), vbInformation, "FilterTime: " & Format$(t, "0.0 sec.")
End Sub
'==================================================================================================
Запуск кода производится из VBE. Результат выгружается на лист (если что-то нашлось). Есть сообщения для основных случаев.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
не уверен, но, возможно, для разных версий Excel этот индекс может быть разным.
john22255, "жёлтый" включает в себя огромную палитру цветов. Если вы задаёте программно, то можно использовать константу vbYellow. Если руками, то посмотрите, какой код цвета получается и запомните его куда-либо.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Евгений Смирнов: Для функции рабочего листа обязательно писать Application.
неправда. Для функции листа обязательно писать ФункцияЛиста (WorksheetFunction). Application ВМЕСТО WorksheetFunction может изменить результат.
VBA.Trim удаляет только ведущие и хвостовые пробелы. Аналог с листа — и двойные. Application.Trim, КАЖЕТСЯ (не точно), позволяет обрабатывать сразу диапазоны, но быстрее цикла не будет. И там ещё какие-то нюансы, и я вообще не советую.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
mik94: Если поставить, например, начало работы 3.5.2024 04:00, а окончание 3.5.2024 12:00 при графике работы с 10:00 до 18:00, то вместо 2 часов формула выдаст 8.
всё правильно считает. Если вы время указываете, то оно учитывается вместо времени графика. Было уже в #4.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
nilske, не считаю, что для счётчиков нужны длинные названия. Тем более, они могут менять свое назначение.
А вообще, счётчики (как и остальные переменные) у меня и так по смыслу названы: r считает строки (Rows), c — столбцы (Columns), n — номера (Number), p — позиции (Positions). Двойные эти буквы тоже, как правило, несут смысл, схожий с одинарными. s — это вообще строковая переменная (String).
Если человек по коду не может понять, что делает конкретная переменная, то тут я ему вряд ли помогу, хотя спросить можно. Возможно, для индивидуального удобства, вам стоит переименовать мои переменные в свои. Я так часто делаю с чужим кодом, чтобы читать было понятнее/привычнее.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
я не формулист (в отличие от медведя, например), но то, что ВПР, ПОИСКПОЗ и всякие …ЕСЛИ работают со знаками подстановки — знаю
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Часть 2. Агрегация на отсортированном по ключам массиве Без подключенной библы bedvit'а тут делать нечего — штатные сортеры уступают многократно и проигрывают, даже не начав сцепку.
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub Test()
Dim aK$(), aV$()
Dim a, b, t!
Const sep = ", "
' Prepare ---------------------------------------
t = Timer ' UnSort. Count of Repeats:
CreateArr2Col a, 100000, 100, True ' 0 | 10 | 100
Debug.Print Round(Timer - t, 2), "CreateArr" ' 0.1 | 0.6 | 6.0
' Variants --------------------------------------
b = a: t = Timer
Sort_Join_BV b, sep, aK, aV
Debug.Print Round(Timer - t, 2), "Sort_Join_BV" ' 0.1 | 0.6 | 7.0
'Debug.Print aK(100), "«" & aV(100) & "»"
b = a: t = Timer
Sort_Mid_BV b, sep, aK, aV
Debug.Print Round(Timer - t, 2), "Sort_Mid_BV" ' 0.1 | 0.6 | 6.8
'Debug.Print aK(100), "«" & aV(100) & "»"
't = Timer
' Progressive_BV a, sep, aK, aV
'Debug.Print Round(Timer - t, 2), "Progressive_BV" ' 0.1 | 1.2 | 13.3
''Debug.Print aK(100), "«" & aV(100) & "»"
' Out of Compare --------------------------------
't = Timer
' Progressive a, sep, aK, aV
'Debug.Print Round(Timer - t, 2), "Progressive" ' 31.2 for 100 Repeats(UnSort)
''Debug.Print aK(100), "«" & aV(100) & "»"
'
'
't = Timer
' Middle a, sep, aK, aV
'Debug.Print Round(Timer - t, 2), "Middle" ' 28.0 for 100 Repeats(UnSort)
''Debug.Print aK(100), "«" & aV(100) & "»"
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
V_BedVit
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Public BV As New BedvitCOM.VBA
'==================================================================================================
'==================================================================================================
'==================================================================================================
Sub Progressive_BV(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim map As New BedvitCOM.UnorderedMap
Dim x, s$, r&, n&
r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r)
For r = 1 To r
s = a2Col_In(r, 1)
If (map.Find(s, x)) Then
aJoin_Out(x) = aJoin_Out(x) & sSep_In & a2Col_In(r, 2)
Else
n = n + 1: map.Insert s, n
aKeys_Out(n) = s
aJoin_Out(n) = a2Col_In(r, 2)
End If
Next r
ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
'==================================================================================================
Sub Sort_Join_BV(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim a, aJ$(), sOld$, sNew$, t!, r&, n&, j&, UBnd&
Const UBcnst& = 100
't = Timer
BV.ArraySortV a2Col_In
'Debug.Print Round(Timer - t, 2), "Sort_Join_BV(Sort)" ' ~ 50% of TotalTime
r = UBound(a2Col_In, 1): UBnd = UBcnst
ReDim aKeys_Out(r), aJoin_Out(r), aJ(UBnd)
't = Timer
sOld = a2Col_In(1, 1)
j = 1: aJ(j) = a2Col_In(1, 2)
For r = 2 To r
sNew = a2Col_In(r, 1)
If (sOld = sNew) Then
If (j = UBnd) Then UBnd = 10 * UBnd: ReDim Preserve aJ(UBnd)
j = j + 1: aJ(j) = a2Col_In(r, 2)
Else
n = n + 1
aKeys_Out(n) = sOld: sOld = sNew
ReDim Preserve aJ(j): aJoin_Out(n) = Join(aJ, sSep_In)
If (UBnd <> UBcnst) Then UBnd = UBcnst: ReDim aJ(UBnd)
j = 1: aJ(j) = a2Col_In(r, 2)
End If
Next r
n = n + 1
aKeys_Out(n) = sOld
ReDim Preserve aJ(j): aJoin_Out(n) = Join(aJ, sSep_In)
'Debug.Print Round(Timer - t, 2), "Sort_Join_BV(Main)" ' ~ 50% of TotalTime
ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
'==================================================================================================
Sub Sort_Mid_BV(a2Col_In, sSep_In$, aKeys_Out() As String, aJoin_Out() As String)
Dim sBuf$, sW$, sOld$, sNew$, t!, r&, n&, lS&, lW&, lP&, ll&
Const lB& = 32767
't = Timer
BV.ArraySortV a2Col_In
'Debug.Print Round(Timer - t, 2), "Sort_Mid(Sort)" ' ~ 40% of TotalTime
r = UBound(a2Col_In, 1)
ReDim aKeys_Out(r), aJoin_Out(r)
lS = Len(sSep_In)
sBuf = Space$(lB)
't = Timer
sOld = a2Col_In(1, 1)
sW = a2Col_In(1, 2): lW = Len(sW)
Mid$(sBuf, 1, lW) = sW: lP = lW
For r = 2 To r
sNew = a2Col_In(r, 1)
If (sOld = sNew) Then
sW = a2Col_In(r, 2): lW = Len(sW)
ll = lP + lS + lW: If (ll > lB) Then Stop: End
Mid$(sBuf, lP + 1, lS) = sSep_In
Mid$(sBuf, lP + 1 + lS, lW) = sW
lP = ll
Else
n = n + 1
aKeys_Out(n) = sOld: sOld = sNew
aJoin_Out(n) = Left$(sBuf, lP)
sW = a2Col_In(r, 2): lW = Len(sW)
Mid$(sBuf, 1, lW) = sW: lP = lW
End If
Next r
n = n + 1
aKeys_Out(n) = sOld
aJoin_Out(n) = Left$(sBuf, lP)
'Debug.Print Round(Timer - t, 2), "Sort_Mid(Main)" ' ~ 60% of TotalTime
ReDim Preserve aKeys_Out(n), aJoin_Out(n)
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
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
BV.ArraySortV aOut, 3
ReDim Preserve aOut(UBound(aOut), 2)
End Sub
'==================================================================================================
'==================================================================================================
'==================================================================================================
V_PRDX
Код
Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
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 r
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 r
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
'==================================================================================================
'==================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
testuser, привет! Спасибо за внимание! Ну, тут не сравнение методов а демонстрация того, что сортировка ключей сильно влияет на скорость наполнения словаря. Совсем неочевидный нюанс, о котором я (да и, наверное, многие, если не все) не знал.
Цитата
testuser: Коллекция оказывалась значительно быстрее на объемах 500 + тыс.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Приветствую! Заметил ещё одно очень странное поведение словарей — скорость заполнения/проверки наличия сильно зависит от порядка ключей в массиве. Отсортированные ключи добавляются/проверяются намного быстрее (~ 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
'==================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Представляю 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. Опциональное булево: вывести новым последним полем количество сгруппированных строк.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Evgenyy, согласен — это странно. Произвол чистой воды, ведь ту же горелую кашу обсуждать вполне себе можно. Возможно, медведь имеет отношение к этой икре и не хочет лиш9него внимания
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Извлечь из исходной комбинации максимальных значений по заданным критериям., Пример: Извлечь из комбинации чисел 1 2 3 5 47 48 максимальных значений то есть 5 из 6
ТС написал в личку. Отвечаю тут. Cristal, здравствуйте. Я смотрел файл и описание — ничего не понял. Времени практически нет, а, учитывая потребность в PayPal (которого у меня нет и не предвидится), то и вообще смысла не вижу (и неинтересно, и неоплачиваемо).
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄