Всем привет. Прилетела мне задача помочь разобраться с отпусками. Посмотрел тут и в готовых решениях есть красивые решения, но мне не подошло. Основная особенность моей задачи была в том что нужно было разнести все даты указанные в двух ячейках: Основная часть отпуска = минимум 14дней Оставшаяся часть отпуска = остальные дни, как хочешь по одному, два ... подряд. Получается неограниченное количество диапазонов.
Поскольку я жутко ленивый, и боюсь ручных КопиПастов - эта задача подтолкнула меня сделать функцию, которая из строки с указанием диапазонов дат и дат создает полный перечень дат. Получился такой вот монстр:
Sub Example() 'Count Dates Debug.Print Application.CountA(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11")) 'Count Dates 2-nd variant Debug.PrintUBound(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11")) + 1 'Count Dates with the specified year Debug.PrintUBound(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11", 2018)) + 1
Debug.Print vbLf 'List all Dates in all ranges Debug.PrintJoin(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11"), vbLf) & vbLf 'List all Dates with sorting and the specified year Debug.PrintJoin(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11", 2018, 1), vbLf) EndSub Function ListDatesFromRanges_(ByVal strListRanges AsString, OptionalByVal addYear&, OptionalByVal Sort_ AsBoolean) AsVariant
'Made by Yaroslav Popov 26/12/2017
Dim dicRanges AsNew Scripting.Dictionary, dicClearRanges AsNew Scripting.Dictionary, dicDates AsNew Scripting.Dictionary, tDate AsDate Dim arr, arr1, i#, ii% ' Clear string, and convert to one format
strListRanges = Replace(strListRanges, ",", ";")
strListRanges = Replace(strListRanges, ":", "-")
strListRanges = Replace(strListRanges, " ", "")
If addYear = 0Then addYear = Year(Now)
arr = Split(strListRanges, ";") For i = LBound(arr) ToUBound(arr)
dicRanges(Trim(arr(i))) = i Next
arr1 = dicRanges.Keys For i = LBound(arr1) ToUBound(arr1) IfInStr(arr1(i), ";") = 0Then dicClearRanges(Trim(arr1(i))) = ii Next
tDate = CDate(arr(0)) DoUntil tDate > CDate(arr(1))
dicDates(tDate) = i
tDate = tDate + 1 Loop Else IfNot arr(0) Like"*#.##.##*"Then arr(0) = arr(0) & "." & addYear
dicDates(CDate(arr(0))) = i EndIf Next
arr = dicDates.Keys If Sort_ Then QuickSort arr, LBound(arr), UBound(arr) IfTypeName(Application.Caller) = "Range"Then
i = Application.Caller.Cells.Count If i - 1 > UBound(arr) ThenReDim Preserve arr(i - 1) EndIf
ListDatesFromRanges_ = arr EndFunction
Sub QuickSort(arr, lo AsLong, hi AsLong) Dim varPivot AsVariant Dim varTmp AsVariant Dim tmpLow AsLong Dim tmpHi AsLong
tmpLow = lo
tmpHi = hi
varPivot = arr((lo + hi) \ 2) DoWhile tmpLow <= tmpHi DoWhile arr(tmpLow) < varPivot And tmpLow < hi
tmpLow = tmpLow + 1 Loop DoWhile varPivot < arr(tmpHi) And tmpHi > lo
tmpHi = tmpHi - 1 Loop If tmpLow <= tmpHi Then
varTmp = arr(tmpLow)
arr(tmpLow) = arr(tmpHi)
arr(tmpHi) = varTmp
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1 EndIf Loop If lo < tmpHi Then QuickSort arr, lo, tmpHi If tmpLow < hi Then QuickSort arr, tmpLow, hi EndSub
Например из строки:
"01.05.2019-05.05.2019;26.03-01.04;5.01;7.05-8.05;29.06;29.10-02.11;29.10.18-02.11.2018" получаем список(массив) дат: 05.01.2018 26.03.2018 27.03.2018 ..... В функцию добавил сортировку, и возможность указать какой год добавить к краткому виду даты, например к 5.01 - по умолчанию добавляется текущий год,
Диапазоны дат с-по - через "-" или ":" .Например : "07.10-09.10" = 07.10, 08.10, 09.10 Несвязные даты - через "," или ";" .Например : "07.10;09.10" = 07.10, 09.10
В общем чтоб много не писать - остальное в файле наглядно видно. Пожелания и замечания в мягкой форме приветствуются .
Всем привет. Прилетела мне задача помочь разобраться с отпусками. Посмотрел тут и в готовых решениях есть красивые решения, но мне не подошло. Основная особенность моей задачи была в том что нужно было разнести все даты указанные в двух ячейках: Основная часть отпуска = минимум 14дней Оставшаяся часть отпуска = остальные дни, как хочешь по одному, два ... подряд. Получается неограниченное количество диапазонов.
Поскольку я жутко ленивый, и боюсь ручных КопиПастов - эта задача подтолкнула меня сделать функцию, которая из строки с указанием диапазонов дат и дат создает полный перечень дат. Получился такой вот монстр:
Sub Example() 'Count Dates Debug.Print Application.CountA(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11")) 'Count Dates 2-nd variant Debug.PrintUBound(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11")) + 1 'Count Dates with the specified year Debug.PrintUBound(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11", 2018)) + 1
Debug.Print vbLf 'List all Dates in all ranges Debug.PrintJoin(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11"), vbLf) & vbLf 'List all Dates with sorting and the specified year Debug.PrintJoin(ListDatesFromRanges_("7.05-8.05,5.01;26.03-01.04;7.05.2017-8.05.2017;29.06;29.10-02.11", 2018, 1), vbLf) EndSub Function ListDatesFromRanges_(ByVal strListRanges AsString, OptionalByVal addYear&, OptionalByVal Sort_ AsBoolean) AsVariant
'Made by Yaroslav Popov 26/12/2017
Dim dicRanges AsNew Scripting.Dictionary, dicClearRanges AsNew Scripting.Dictionary, dicDates AsNew Scripting.Dictionary, tDate AsDate Dim arr, arr1, i#, ii% ' Clear string, and convert to one format
strListRanges = Replace(strListRanges, ",", ";")
strListRanges = Replace(strListRanges, ":", "-")
strListRanges = Replace(strListRanges, " ", "")
If addYear = 0Then addYear = Year(Now)
arr = Split(strListRanges, ";") For i = LBound(arr) ToUBound(arr)
dicRanges(Trim(arr(i))) = i Next
arr1 = dicRanges.Keys For i = LBound(arr1) ToUBound(arr1) IfInStr(arr1(i), ";") = 0Then dicClearRanges(Trim(arr1(i))) = ii Next
tDate = CDate(arr(0)) DoUntil tDate > CDate(arr(1))
dicDates(tDate) = i
tDate = tDate + 1 Loop Else IfNot arr(0) Like"*#.##.##*"Then arr(0) = arr(0) & "." & addYear
dicDates(CDate(arr(0))) = i EndIf Next
arr = dicDates.Keys If Sort_ Then QuickSort arr, LBound(arr), UBound(arr) IfTypeName(Application.Caller) = "Range"Then
i = Application.Caller.Cells.Count If i - 1 > UBound(arr) ThenReDim Preserve arr(i - 1) EndIf
ListDatesFromRanges_ = arr EndFunction
Sub QuickSort(arr, lo AsLong, hi AsLong) Dim varPivot AsVariant Dim varTmp AsVariant Dim tmpLow AsLong Dim tmpHi AsLong
tmpLow = lo
tmpHi = hi
varPivot = arr((lo + hi) \ 2) DoWhile tmpLow <= tmpHi DoWhile arr(tmpLow) < varPivot And tmpLow < hi
tmpLow = tmpLow + 1 Loop DoWhile varPivot < arr(tmpHi) And tmpHi > lo
tmpHi = tmpHi - 1 Loop If tmpLow <= tmpHi Then
varTmp = arr(tmpLow)
arr(tmpLow) = arr(tmpHi)
arr(tmpHi) = varTmp
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1 EndIf Loop If lo < tmpHi Then QuickSort arr, lo, tmpHi If tmpLow < hi Then QuickSort arr, tmpLow, hi EndSub
Например из строки:
"01.05.2019-05.05.2019;26.03-01.04;5.01;7.05-8.05;29.06;29.10-02.11;29.10.18-02.11.2018" получаем список(массив) дат: 05.01.2018 26.03.2018 27.03.2018 ..... В функцию добавил сортировку, и возможность указать какой год добавить к краткому виду даты, например к 5.01 - по умолчанию добавляется текущий год,
Function ListDatesFromRanges(ByVal strListRanges AsString, OptionalByVal addYear&, OptionalByVal Sort_ AsBoolean) Dim AL AsObject, i& Dim D() AsDate
addYear = IIf(addYear, addYear, Year(Now)) WithCreateObject("Vbscript.regexp")
.Pattern = "(?:(?:(\d+\.\d+)(\.\d+)*)(?:[-:](\d+\.\d+)(\.\d+)*)*)"
.Global = True IfNot .test(strListRanges) ThenExitFunction Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim D(1) OnErrorResumeNext For i = 0To1
D(i) = .subMatches(i * 2) & IIf(IsEmpty(.subMatches(i * 2 + 1)), "." & addYear, "") Next OnErrorGoTo0 Do IfNot AL.Contains(D(0)) Then AL.Add D(0)
D(0) = D(0) + 1 LoopWhile D(1) >= D(0) EndWith Next EndWith If Sort_ Then AL.Sort
ListDatesFromRanges = AL.Toarray Set AL = Nothing EndFunction
Привет. Немного попаразитировал на коде
Function ListDatesFromRanges(ByVal strListRanges AsString, OptionalByVal addYear&, OptionalByVal Sort_ AsBoolean) Dim AL AsObject, i& Dim D() AsDate
addYear = IIf(addYear, addYear, Year(Now)) WithCreateObject("Vbscript.regexp")
.Pattern = "(?:(?:(\d+\.\d+)(\.\d+)*)(?:[-:](\d+\.\d+)(\.\d+)*)*)"
.Global = True IfNot .test(strListRanges) ThenExitFunction Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim D(1) OnErrorResumeNext For i = 0To1
D(i) = .subMatches(i * 2) & IIf(IsEmpty(.subMatches(i * 2 + 1)), "." & addYear, "") Next OnErrorGoTo0 Do IfNot AL.Contains(D(0)) Then AL.Add D(0)
D(0) = D(0) + 1 LoopWhile D(1) >= D(0) EndWith Next EndWith If Sort_ Then AL.Sort
ListDatesFromRanges = AL.Toarray Set AL = Nothing EndFunction
Отлынивая от резки новогодних салатов, тоже повыпендриваюсь, не паразитируя, но творчески заимствуя некоторые операторы у предыдущих ораторов А также наследуя традиции темы Автоматическое заполнение элементов диапазона - с переходом от диапазонов внутри текстовой строки к диапазонам таблицы и обратно с преобразованием адресов диапазонов таблицы в числовые характеристики решаемой задачи, в данном конкретном случае - в даты.
Function ListDatesFromRanges_G(ByVal strListRanges AsString, OptionalByVal addYear&, OptionalByVal SortByDesc AsBoolean) AsVariant Dim a, b, c, d(), r() Dim addr AsString, full AsString Dim rng As Range, cell As Range Dim i AsInteger
'разбираем исходную строку, превращая ее содержимое в составной адрес диапазона таблицы For Each a InSplit(Replace(Replace(strListRanges, "-", ":"), ";", ","), ",")
addr = "" For Each b InSplit(a, ":")
c = Split(b & "." & IIf(addYear, addYear, Year(Now)), ".") 'добавляем год всегда - если при разборе получается c(3), то просто его не используем
addr = addr & ":A" & CLng(DateSerial(c(2), c(1), c(0))) Next b
full = full & ",A" & Mid(addr, 3) Next a
'определяем диапазон таблицы, ячейки которого будут "имитировать" наши даты '(Intersect для обеспечения уникальности (неповторяемости адресов) ячеек) Set rng = Intersect(Range(Mid(full, 2)), Range("A1:A65000")) '65000 - это 16.12.2077 - пока хватит :) ReDim d(1To rng.Cells.Count), r(1To rng.Cells.Count)
'составляем список дат как целых чисел - номеров строк всех ячеек диапазона таблицы For Each cell In rng.Cells
i = i + 1
r(i) = cell.Row Next 'получаем окончательный список уникальных дат в хронологическом порядке '- возрастающем (если SortByDesc = False) или убывающем (если SortByDesc = True) For i = 1To rng.Cells.Count With WorksheetFunction
d(i) = CDate(IIf(SortByDesc, .Large(r, i), .Small(r, i))) EndWith Next
ListDatesFromRanges_G = d EndFunction
Третий параметр исходной сигнатуры функции - "сортировать/не сортировать" - я в своей версии убрал, так как не вижу практического смысла в неотсортированном списке дат и выдаю из функции всегда отсортированную хронологическую последовательность. А вот за направление сортировки - по возрастанию или убыванию - как раз и отвечает мой третий параметр SortByDesc (= True для сортировки по убыванию, иначе - по возрастанию).
С Новым Годом!
Отлынивая от резки новогодних салатов, тоже повыпендриваюсь, не паразитируя, но творчески заимствуя некоторые операторы у предыдущих ораторов А также наследуя традиции темы Автоматическое заполнение элементов диапазона - с переходом от диапазонов внутри текстовой строки к диапазонам таблицы и обратно с преобразованием адресов диапазонов таблицы в числовые характеристики решаемой задачи, в данном конкретном случае - в даты.
Function ListDatesFromRanges_G(ByVal strListRanges AsString, OptionalByVal addYear&, OptionalByVal SortByDesc AsBoolean) AsVariant Dim a, b, c, d(), r() Dim addr AsString, full AsString Dim rng As Range, cell As Range Dim i AsInteger
'разбираем исходную строку, превращая ее содержимое в составной адрес диапазона таблицы For Each a InSplit(Replace(Replace(strListRanges, "-", ":"), ";", ","), ",")
addr = "" For Each b InSplit(a, ":")
c = Split(b & "." & IIf(addYear, addYear, Year(Now)), ".") 'добавляем год всегда - если при разборе получается c(3), то просто его не используем
addr = addr & ":A" & CLng(DateSerial(c(2), c(1), c(0))) Next b
full = full & ",A" & Mid(addr, 3) Next a
'определяем диапазон таблицы, ячейки которого будут "имитировать" наши даты '(Intersect для обеспечения уникальности (неповторяемости адресов) ячеек) Set rng = Intersect(Range(Mid(full, 2)), Range("A1:A65000")) '65000 - это 16.12.2077 - пока хватит :) ReDim d(1To rng.Cells.Count), r(1To rng.Cells.Count)
'составляем список дат как целых чисел - номеров строк всех ячеек диапазона таблицы For Each cell In rng.Cells
i = i + 1
r(i) = cell.Row Next 'получаем окончательный список уникальных дат в хронологическом порядке '- возрастающем (если SortByDesc = False) или убывающем (если SortByDesc = True) For i = 1To rng.Cells.Count With WorksheetFunction
d(i) = CDate(IIf(SortByDesc, .Large(r, i), .Small(r, i))) EndWith Next
ListDatesFromRanges_G = d EndFunction
Третий параметр исходной сигнатуры функции - "сортировать/не сортировать" - я в своей версии убрал, так как не вижу практического смысла в неотсортированном списке дат и выдаю из функции всегда отсортированную хронологическую последовательность. А вот за направление сортировки - по возрастанию или убыванию - как раз и отвечает мой третий параметр SortByDesc (= True для сортировки по убыванию, иначе - по возрастанию).
С прошедшим всех . krosav4ig, Gustav, смотрю Ваши варианты - мозг проснулся после выходных ... и чуть не закипел .
krosav4ig, интересно - с regexp думал, но мне кажется что с ним дольше будет на большИх объемах. Есть баг: если поменять год с 2018 на 2019 - то даты 01.05.2019-05.05.2019 - 2018-го года. на сколько я понял нужно немного поправить строку
К моему величайшему стыду про "system.collections.arraylist" и не знал. Интересно как он справится с большим количеством данных, и есть ли везде эта библиотека? В общем озадачил меня - придется изучать .
Gustav, тоже очень интересно. Использовать диапазоны, для получения списка - даже и не додумался бы. . Смущает меня (пока) два момента, которые касаются быстродействия и универсальности (просто часто использую функции для работы данными из БД):
For Each cell In rng.Cells
...
по своему опыту "cell In rng.Cells" - работает достаточно долго - как в этом случае нужно посмотреть. и
With WorksheetFunction
d(i) = CDate(IIf(SortByDesc, .Large(r, i), .Small(r, i))) EndWith
аналогично с предыдущим - мне кажется будет тормозить на большом количестве строк. Я использую функцию не только для получения списка дат, но и для получения количества дней, поэтому сортировку делал опционной - чтобы было быстрее. В Вашей функции количество определяется в первой части функции, поэтому думаю было бы хорошо добавить вариант "ответа" фунции(количество/список), и если нужно просто количество дней, то выходить из нее, не тратя время на просчет второй части.
В общем протестирую, немного позже - отпишусь тут .
С прошедшим всех . krosav4ig, Gustav, смотрю Ваши варианты - мозг проснулся после выходных ... и чуть не закипел .
krosav4ig, интересно - с regexp думал, но мне кажется что с ним дольше будет на большИх объемах. Есть баг: если поменять год с 2018 на 2019 - то даты 01.05.2019-05.05.2019 - 2018-го года. на сколько я понял нужно немного поправить строку
К моему величайшему стыду про "system.collections.arraylist" и не знал. Интересно как он справится с большим количеством данных, и есть ли везде эта библиотека? В общем озадачил меня - придется изучать .
Gustav, тоже очень интересно. Использовать диапазоны, для получения списка - даже и не додумался бы. . Смущает меня (пока) два момента, которые касаются быстродействия и универсальности (просто часто использую функции для работы данными из БД):
For Each cell In rng.Cells
...
по своему опыту "cell In rng.Cells" - работает достаточно долго - как в этом случае нужно посмотреть. и
With WorksheetFunction
d(i) = CDate(IIf(SortByDesc, .Large(r, i), .Small(r, i))) EndWith
аналогично с предыдущим - мне кажется будет тормозить на большом количестве строк. Я использую функцию не только для получения списка дат, но и для получения количества дней, поэтому сортировку делал опционной - чтобы было быстрее. В Вашей функции количество определяется в первой части функции, поэтому думаю было бы хорошо добавить вариант "ответа" фунции(количество/список), и если нужно просто количество дней, то выходить из нее, не тратя время на просчет второй части.
В общем протестирую, немного позже - отпишусь тут .SLAVICK
Как и обещал - сделал сравнение. пока у мну быстрее всех работает на вывод всех дат : На 1000 строках: Slavick: 2,2188 Gustav: 10,6016 krosav4ig: 5,3438
Как и предполагал - у Gustav, притормаживает из-за работы с диапазонами и функцией Large/Small у krosav4ig - думаю из-за регулярки немного тормозит- они такие противные на длинных текстах . Могу ошибаться - по причинам детально в этапы не влазил - просто предположение..
Как и обещал - сделал сравнение. пока у мну быстрее всех работает на вывод всех дат : На 1000 строках: Slavick: 2,2188 Gustav: 10,6016 krosav4ig: 5,3438
Как и предполагал - у Gustav, притормаживает из-за работы с диапазонами и функцией Large/Small у krosav4ig - думаю из-за регулярки немного тормозит- они такие противные на длинных текстах . Могу ошибаться - по причинам детально в этапы не влазил - просто предположение..SLAVICK
у Gustav, притормаживает из-за работы с диапазонами и функцией Large/Small
ТОЛЬКО из-за Large/Small. Закомментировал эту сортировку, придав окончанию своей функции следующий вид:
'составляем список дат как целых чисел - номеров строк всех ячеек диапазона таблицы For Each cell In rng.Cells
i = i + 1
d(i) = CDate(cell.Row) Next 'получаем окончательный список уникальных дат в хронологическом порядке '- возрастающем (если SortByDesc = False) или убывающем (если SortByDesc = True) 'For i = 1 To rng.Cells.Count ' With WorksheetFunction ' d(i) = CDate(IIf(SortByDesc, .Large(r, i), .Small(r, i))) ' End With 'Next
ListDatesFromRanges_Gustav = d EndFunction
Получил такие результаты на своем компутере:
ДО комментирования сортировки:
Slavick: 1,0625
Gustav: 7,3359
krosav4ig: 3,6641
ПОСЛЕ комментирования сортировки:
Slavick: 1,0781
Gustav: 0,4063
krosav4ig: 3,5391
у Gustav, притормаживает из-за работы с диапазонами и функцией Large/Small
ТОЛЬКО из-за Large/Small. Закомментировал эту сортировку, придав окончанию своей функции следующий вид:
'составляем список дат как целых чисел - номеров строк всех ячеек диапазона таблицы For Each cell In rng.Cells
i = i + 1
d(i) = CDate(cell.Row) Next 'получаем окончательный список уникальных дат в хронологическом порядке '- возрастающем (если SortByDesc = False) или убывающем (если SortByDesc = True) 'For i = 1 To rng.Cells.Count ' With WorksheetFunction ' d(i) = CDate(IIf(SortByDesc, .Large(r, i), .Small(r, i))) ' End With 'Next
ListDatesFromRanges_Gustav = d EndFunction
Получил такие результаты на своем компутере:
ДО комментирования сортировки:
Slavick: 1,0625
Gustav: 7,3359
krosav4ig: 3,6641
ПОСЛЕ комментирования сортировки:
Slavick: 1,0781
Gustav: 0,4063
krosav4ig: 3,5391
А у меня Вы сортировку не отключали? Дома решил посмотреть на ноутбуке(win10 office 2016*64) - код krosav4ig не запустился- выдало "Automation Error" - причины расследую... поэтому сравнивал только две процедуры:
А у меня Вы сортировку не отключали? Дома решил посмотреть на ноутбуке(win10 office 2016*64) - код krosav4ig не запустился- выдало "Automation Error" - причины расследую... поэтому сравнивал только две процедуры:
отчего же нельзя? . будет время - докину в сравнение. Но сразу скажу что когда-то тестировал скорость словаря и коллекции - словарь победил + там есть выгрузка ключей сразу в массив.(это я про второй вариант) И сортировку, как придумал Gustav, - наверное нужно переделать(и мне) опционно по убыванию или возрастанию - для универсальности.
отчего же нельзя? . будет время - докину в сравнение. Но сразу скажу что когда-то тестировал скорость словаря и коллекции - словарь победил + там есть выгрузка ключей сразу в массив.(это я про второй вариант) И сортировку, как придумал Gustav, - наверное нужно переделать(и мне) опционно по убыванию или возрастанию - для универсальности.SLAVICK
то ли у мну моск еще не очухался то ли че-то тут не то...
Sub test() Dim AL AsObject, Dic AsObject, Coll As Collection, t#, r# Dim Al1 AsObject Dim Arr()
Randomize Set AL = CreateObject("system.collections.arraylist")
t = Timer For i = 1To10 ^ 6
r = Rnd
AL.Add r Next
t = Timer - t Debug.Print"filling arraylist with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" Set Al1 = AL.Clone
t = Timer
AL.Sort
t = Timer - t Debug.Print"sorting 10^6 random numbers in ascending order with Arraylist took "; Format(t, "0.0000"); " seconds"
t = Timer
Al1.Sort
Al1.Reverse
t = Timer - t Debug.Print"sorting 10^6 random numbers in descending order with Arraylist took "; Format(t, "0.0000"); " seconds" Set AL = Nothing: Set Al1 = Nothing Set Dic = CreateObject("scripting.dictionary")
t = Timer For i = 1To10 ^ 6
r = Rnd
Dic.Add r, r Next
t = Timer - t Debug.Print"filling dictionary with 10^6 random numbers took "; Format(t, "0.0000"); " seconds"
Arr = Dic.Items
t = Timer
QuickSort Arr, LBound(Arr), UBound(Arr)
t = Timer - t Debug.Print"sorting 10^6 random numbers in descending order with quicksort took "; Format(t, "0.0000"); " seconds" Set Dic = Nothing Set Coll = New Collection
t = Timer For i = 1To10 ^ 6
r = Rnd
Coll.Add r Next
t = Timer - t Debug.Print"filling collection with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" EndSub
filling arraylist with 10^6 random numbers took 10,6250 seconds
sorting 10^6 random numbers in ascending order with Arraylist took 1,3906 seconds
sorting 10^6 random numbers in descending order with Arraylist took 1,4375 seconds
filling dictionary with 10^6 random numbers took 72,2813 seconds
sorting 10^6 random numbers in descending order with quicksort took 7,3203 seconds
filling collection with 10^6 random numbers took 0,2188 seconds
Добавил сортировку по убыванию
'Sort_ ' 0: without sorting ' 1: sort in ascending order ' 2: sort in descending order Function ListDatesFromRanges_krosav4ig(ByVal strListRanges AsString, OptionalByVal addYear&, OptionalByVal Sort_ AsByte = 0) Dim AL AsObject, i&, Match Dim d() AsDate
strListRanges = ";" & strListRanges & ";"
addYear = IIf(addYear, addYear, Year(Now)) WithCreateObject("Vbscript.regexp")
.Pattern = "((?:(\d+\.\d+)(\.\d+)*)(?:[- :]*(\d+\.\d+)(\.\d+)*)*[;, ]*)(?!.*[;, ]*\1[;,]*)"'на всяк случай сделал выборку уникальных диапазонов дат
.Global = True IfNot .Test(strListRanges) ThenExitFunction Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim d(1) OnErrorResumeNext For i = 1To2
d(i - 1) = .subMatches(i * 2 - 1) & IIf(IsEmpty(.subMatches(i * 2)), "." & addYear, .subMatches(i * 2)) Next OnErrorGoTo0 Do IfNot AL.Contains(d(0)) Then AL.Add d(0)
d(0) = d(0) + 1 LoopWhile d(1) >= d(0) EndWith Next EndWith If Sort_ Then AL.Sort If Sort_ = 2Then AL.Reverse
ListDatesFromRanges_krosav4ig = AL.toarray Set AL = Nothing EndFunction
то ли у мну моск еще не очухался то ли че-то тут не то...
Sub test() Dim AL AsObject, Dic AsObject, Coll As Collection, t#, r# Dim Al1 AsObject Dim Arr()
Randomize Set AL = CreateObject("system.collections.arraylist")
t = Timer For i = 1To10 ^ 6
r = Rnd
AL.Add r Next
t = Timer - t Debug.Print"filling arraylist with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" Set Al1 = AL.Clone
t = Timer
AL.Sort
t = Timer - t Debug.Print"sorting 10^6 random numbers in ascending order with Arraylist took "; Format(t, "0.0000"); " seconds"
t = Timer
Al1.Sort
Al1.Reverse
t = Timer - t Debug.Print"sorting 10^6 random numbers in descending order with Arraylist took "; Format(t, "0.0000"); " seconds" Set AL = Nothing: Set Al1 = Nothing Set Dic = CreateObject("scripting.dictionary")
t = Timer For i = 1To10 ^ 6
r = Rnd
Dic.Add r, r Next
t = Timer - t Debug.Print"filling dictionary with 10^6 random numbers took "; Format(t, "0.0000"); " seconds"
Arr = Dic.Items
t = Timer
QuickSort Arr, LBound(Arr), UBound(Arr)
t = Timer - t Debug.Print"sorting 10^6 random numbers in descending order with quicksort took "; Format(t, "0.0000"); " seconds" Set Dic = Nothing Set Coll = New Collection
t = Timer For i = 1To10 ^ 6
r = Rnd
Coll.Add r Next
t = Timer - t Debug.Print"filling collection with 10^6 random numbers took "; Format(t, "0.0000"); " seconds" EndSub
filling arraylist with 10^6 random numbers took 10,6250 seconds
sorting 10^6 random numbers in ascending order with Arraylist took 1,3906 seconds
sorting 10^6 random numbers in descending order with Arraylist took 1,4375 seconds
filling dictionary with 10^6 random numbers took 72,2813 seconds
sorting 10^6 random numbers in descending order with quicksort took 7,3203 seconds
filling collection with 10^6 random numbers took 0,2188 seconds
Добавил сортировку по убыванию
'Sort_ ' 0: without sorting ' 1: sort in ascending order ' 2: sort in descending order Function ListDatesFromRanges_krosav4ig(ByVal strListRanges AsString, OptionalByVal addYear&, OptionalByVal Sort_ AsByte = 0) Dim AL AsObject, i&, Match Dim d() AsDate
strListRanges = ";" & strListRanges & ";"
addYear = IIf(addYear, addYear, Year(Now)) WithCreateObject("Vbscript.regexp")
.Pattern = "((?:(\d+\.\d+)(\.\d+)*)(?:[- :]*(\d+\.\d+)(\.\d+)*)*[;, ]*)(?!.*[;, ]*\1[;,]*)"'на всяк случай сделал выборку уникальных диапазонов дат
.Global = True IfNot .Test(strListRanges) ThenExitFunction Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim d(1) OnErrorResumeNext For i = 1To2
d(i - 1) = .subMatches(i * 2 - 1) & IIf(IsEmpty(.subMatches(i * 2)), "." & addYear, .subMatches(i * 2)) Next OnErrorGoTo0 Do IfNot AL.Contains(d(0)) Then AL.Add d(0)
d(0) = d(0) + 1 LoopWhile d(1) >= d(0) EndWith Next EndWith If Sort_ Then AL.Sort If Sort_ = 2Then AL.Reverse
ListDatesFromRanges_krosav4ig = AL.toarray Set AL = Nothing EndFunction
Вы не рассчитали этот ОЧЕНЬ важный показатель . а он у коллекции жутко тормозит - она не любит отдавать данные . Я попаразитировал на Вашем коде и добавил пару показателей..
N = 10^5
t = Timer
arr = AL.toarray
t = Timer - t Debug.Print"items to array arraylist " & N & " random numbers took "; Format(t, "0.0000"); " seconds"
Dim DIC_NEW AsNew Scripting.Dictionary
t = Timer For i = 1To N
r = Rnd
DIC_NEW(r) = 1 Next
t = Timer - t Debug.Print"filling NEW dictionary with " & N & " random numbers took "; Format(t, "0.0000"); " seconds"
t = Timer
arr = Dic.Items
t = Timer - t Debug.Print"keys to array dictionary " & N & " random numbers took "; Format(t, "0.0000"); " seconds"
t = Timer
arr = DIC_NEW.Items
t = Timer - t Debug.Print"keys to array NEW dictionary " & N & " random numbers took "; Format(t, "0.0000"); " seconds"
t = Timer ReDim arr(1To Coll.Count) For i = 1To Coll.Count
arr(i) = Coll.Item(i) Next
t = Timer - t Debug.Print"items to array NEW collection with " & N & " numbers took "; Format(t, "0.0000"); " seconds"
Set Coll = Nothing
Весь код не влазит в сообщение - поэтому только то что добавил. Потом протестировал на 10^5 и 10^6 - получились такие результаты:
filling arraylist with 100000 random numbers took 1,1484 seconds
items to array arraylist 100000 random numbers took 0,0234 seconds
sorting 100000 random numbers in ascending order with Arraylist took 0,1250 seconds
sorting 100000 random numbers in descending order with Arraylist took 0,1250 seconds
filling dictionary with 100000 random numbers took 0,7969 seconds
filling NEW dictionary with 100000 random numbers took 0,7578 seconds
keys to array dictionary 100000 random numbers took 0,0156 seconds
keys to array NEW dictionary 100000 random numbers took 0,0156 seconds
sorting 100000 random numbers in descending order with quicksort took 0,6094 seconds
filling collection with 100000 random numbers took 0,0313 seconds
items to array NEW collection with 100000 numbers took 164,5234 seconds
filling arraylist with 1000000 random numbers took 11,2969 seconds
items to array arraylist 1000000 random numbers took 0,2266 seconds
sorting 1000000 random numbers in ascending order with Arraylist took 1,7500 seconds
sorting 1000000 random numbers in descending order with Arraylist took 1,7969 seconds
filling dictionary with 1000000 random numbers took 105,9844 seconds
filling NEW dictionary with 1000000 random numbers took 91,7266 seconds
keys to array dictionary 1000000 random numbers took 0,1719 seconds
keys to array NEW dictionary 1000000 random numbers took 0,1563 seconds
sorting 1000000 random numbers in descending order with quicksort took 7,1953 seconds
filling collection with 1000000 random numbers took 0,3594 seconds
items to array NEW collection with 235734 numbers took 1026,0313 seconds
Дождатся завершения items to array NEW collection - не смог, поэтому остановил код на 235734, и это заняло у моего ноута 1026с Странно, что на 10^5 - показатели словаря лучше чем у arraylist, а при 10^6 - значительно хуже По поводу работы со словарем: есть несколько тонкостей, которые улучшают работу с ним: можно писать не
DIC.Add r, r
а
DIC(r) = 1
этого достаточно для создания словаря без ошибок, если нам нужны просто уникальные значения, без айтемов.
вместо
Set Dic = CreateObject("scripting.dictionary")
лучше подключить библиотеку и использовать :
Dim DIC_NEW AsNew Scripting.Dictionary
Тогда будет быстрее работать + сразу подсказки вылазят - удобно .
Вы не рассчитали этот ОЧЕНЬ важный показатель . а он у коллекции жутко тормозит - она не любит отдавать данные . Я попаразитировал на Вашем коде и добавил пару показателей..
N = 10^5
t = Timer
arr = AL.toarray
t = Timer - t Debug.Print"items to array arraylist " & N & " random numbers took "; Format(t, "0.0000"); " seconds"
Dim DIC_NEW AsNew Scripting.Dictionary
t = Timer For i = 1To N
r = Rnd
DIC_NEW(r) = 1 Next
t = Timer - t Debug.Print"filling NEW dictionary with " & N & " random numbers took "; Format(t, "0.0000"); " seconds"
t = Timer
arr = Dic.Items
t = Timer - t Debug.Print"keys to array dictionary " & N & " random numbers took "; Format(t, "0.0000"); " seconds"
t = Timer
arr = DIC_NEW.Items
t = Timer - t Debug.Print"keys to array NEW dictionary " & N & " random numbers took "; Format(t, "0.0000"); " seconds"
t = Timer ReDim arr(1To Coll.Count) For i = 1To Coll.Count
arr(i) = Coll.Item(i) Next
t = Timer - t Debug.Print"items to array NEW collection with " & N & " numbers took "; Format(t, "0.0000"); " seconds"
Set Coll = Nothing
Весь код не влазит в сообщение - поэтому только то что добавил. Потом протестировал на 10^5 и 10^6 - получились такие результаты:
filling arraylist with 100000 random numbers took 1,1484 seconds
items to array arraylist 100000 random numbers took 0,0234 seconds
sorting 100000 random numbers in ascending order with Arraylist took 0,1250 seconds
sorting 100000 random numbers in descending order with Arraylist took 0,1250 seconds
filling dictionary with 100000 random numbers took 0,7969 seconds
filling NEW dictionary with 100000 random numbers took 0,7578 seconds
keys to array dictionary 100000 random numbers took 0,0156 seconds
keys to array NEW dictionary 100000 random numbers took 0,0156 seconds
sorting 100000 random numbers in descending order with quicksort took 0,6094 seconds
filling collection with 100000 random numbers took 0,0313 seconds
items to array NEW collection with 100000 numbers took 164,5234 seconds
filling arraylist with 1000000 random numbers took 11,2969 seconds
items to array arraylist 1000000 random numbers took 0,2266 seconds
sorting 1000000 random numbers in ascending order with Arraylist took 1,7500 seconds
sorting 1000000 random numbers in descending order with Arraylist took 1,7969 seconds
filling dictionary with 1000000 random numbers took 105,9844 seconds
filling NEW dictionary with 1000000 random numbers took 91,7266 seconds
keys to array dictionary 1000000 random numbers took 0,1719 seconds
keys to array NEW dictionary 1000000 random numbers took 0,1563 seconds
sorting 1000000 random numbers in descending order with quicksort took 7,1953 seconds
filling collection with 1000000 random numbers took 0,3594 seconds
items to array NEW collection with 235734 numbers took 1026,0313 seconds
Дождатся завершения items to array NEW collection - не смог, поэтому остановил код на 235734, и это заняло у моего ноута 1026с Странно, что на 10^5 - показатели словаря лучше чем у arraylist, а при 10^6 - значительно хуже По поводу работы со словарем: есть несколько тонкостей, которые улучшают работу с ним: можно писать не
DIC.Add r, r
а
DIC(r) = 1
этого достаточно для создания словаря без ошибок, если нам нужны просто уникальные значения, без айтемов.
вместо
Set Dic = CreateObject("scripting.dictionary")
лучше подключить библиотеку и использовать :
Dim DIC_NEW AsNew Scripting.Dictionary
Тогда будет быстрее работать + сразу подсказки вылазят - удобно .SLAVICK
Sub test() Dim Coll As Collection, n& Dim s As kludge, it As kludge Dim arr()
n = 10 ^ 6
Randomize Set Coll = New Collection
t = Timer For i = 1To n Set s = New kludge
Coll.Add s(Rnd) Next
t = Timer - t Debug.Print"filling collection with "; n; " random numbers took "; Format(t, "0.0000"); " seconds" ReDim arr(1To Coll.Count)
i = 0
t = Timer For Each it In Coll
i = i + 1
arr(i) = it.Value Next
t = Timer - t Debug.Print"copying "; n; " values from objects in collection to an array took "; Format(t, "0.0000"); " seconds" EndSub
PrivateValAsVariant PublicPropertyGet Self(v) Val = v Set Self = Me EndProperty PublicPropertyGet Value()
Value = Val EndProperty
Sub test() Dim Coll As Collection, n& Dim s As kludge, it As kludge Dim arr()
n = 10 ^ 6
Randomize Set Coll = New Collection
t = Timer For i = 1To n Set s = New kludge
Coll.Add s(Rnd) Next
t = Timer - t Debug.Print"filling collection with "; n; " random numbers took "; Format(t, "0.0000"); " seconds" ReDim arr(1To Coll.Count)
i = 0
t = Timer For Each it In Coll
i = i + 1
arr(i) = it.Value Next
t = Timer - t Debug.Print"copying "; n; " values from objects in collection to an array took "; Format(t, "0.0000"); " seconds" EndSub
PrivateValAsVariant PublicPropertyGet Self(v) Val = v Set Self = Me EndProperty PublicPropertyGet Value()
Value = Val EndProperty
Sub testALLWithoutKluge() Dim coll As Collection, n& Dim AL AsObject, Dic AsObject, t#, r# Dim Al1 AsObject Dim arr()
n = 10 ^ 6
Randomize ' ======Collections================================== Set coll = New Collection OnErrorResumeNext
t = Timer For i = 1To n
coll.Add 1 Next
t = Timer - t Debug.Print"collection.count = " & coll.Count Debug.Print"filling collection with "; n; " random numbers took "; Format(t, "0.0000"); " seconds"
' ======Collections with KEY================================== Set coll = New Collection OnErrorResumeNext
t = Timer For i = 1To n
coll.Add 1, CStr(Rnd) Next
t = Timer - t Debug.Print"collection.count = " & coll.Count Debug.Print"filling collection with "; n; " random numbers took "; Format(t, "0.0000"); " seconds" EndSub
это по поводу добавления в коллекцию - Вы предложили - а я упустил...
For i = 1To n
coll.Add 1 Next
создает n элементов = 1, хотя нам же нужно было получить уникальные... для arraylist похоже та же беда:
Set AL = CreateObject("system.collections.arraylist")
t = Timer For i = 1To n
r = Rnd
AL.Add 1 Next Debug.Print AL.Count
Без Класса - быстрее отрабатывает. Интересно выходит:
'With Class Module kluge
filling collection with 100000 random numbers took 0,2793 seconds
copying 100000 values from objects in collection Use For Each...Next to an array took 0,0371 seconds
copying 100000 values from objects in collection Use For ...Next to an array took 30,2617 seconds 'Without Class Module kluge
filling collection with 100000 random numbers took 0,0391 seconds
copying 100000 values from objects in collection Use For Each...Next to an array took 0,0156 seconds
copying 100000 values from objects in collection Use For...Next to an array took 29,4785 seconds
Получается, что Coll(i) - желательно вообще не использовать при передаче элементов коллекции в массив...
Решил добавить еще один показатель: Время проверки наличия элемента в коллекции(словаре). для коллекции придумался такой код:
Function CollectionContains1(myCol As Collection, checkVal AsVariant) AsBoolean OnErrorResumeNext
myCol.Add checkVal, CStr(checkVal) If Err Then CollectionContains1 = TrueElse myCol.Remove (CStr(checkVal)) EndFunction
Так на порядок быстрее чем:
Function CollectionContains(myCol As Collection, checkVal AsVariant) AsBoolean OnErrorResumeNext
CollectionContains = False Dim it AsVariant For Each it In myCol If it = checkVal Then
CollectionContains = True ExitFunction EndIf Next EndFunction
Для arraylist похоже нужно сделать проверку элементов, как и для обычной коллекции? Получились такие вот результаты:
test Collections, Dictionary, arraylist:
===================================================================================================
filling collection with 10 ^ 5 random numbers took 0,6719 seconds
copying 10 ^ 5 values from objects in collection Use For Each...Next to an array took 0,0078 seconds
Check1 10 ^ 5 values in collection took 1,1953 seconds
filling dictionary with 10 ^ 5 random numbers took 0,2383 seconds
keys to array dictionary 10 ^ 5 random numbers took 0,0039 seconds
sorting 10 ^ 5 random numbers in descending order with quicksort took 0,0000 seconds
filling NEW dictionary with 10 ^ 5 random numbers took 0,1523 seconds
keys to array NEW dictionary 10 ^ 5 random numbers took 0,0039 seconds
Check 10 ^ 5 values in NEW dictionary took 0,3594 seconds
filling arraylist with 10 ^ 5 random numbers took 0,3867 seconds
sorting 10 ^ 5 random numbers in ascending order with Arraylist took 0,0508 seconds
sorting 10 ^ 5 random numbers in descending order with Arraylist took 0,0508 seconds
items to array arraylist 10 ^ 5 random numbers took 0,0117 seconds
Sub testALLWithoutKluge() Dim coll As Collection, n& Dim AL AsObject, Dic AsObject, t#, r# Dim Al1 AsObject Dim arr()
n = 10 ^ 6
Randomize ' ======Collections================================== Set coll = New Collection OnErrorResumeNext
t = Timer For i = 1To n
coll.Add 1 Next
t = Timer - t Debug.Print"collection.count = " & coll.Count Debug.Print"filling collection with "; n; " random numbers took "; Format(t, "0.0000"); " seconds"
' ======Collections with KEY================================== Set coll = New Collection OnErrorResumeNext
t = Timer For i = 1To n
coll.Add 1, CStr(Rnd) Next
t = Timer - t Debug.Print"collection.count = " & coll.Count Debug.Print"filling collection with "; n; " random numbers took "; Format(t, "0.0000"); " seconds" EndSub
это по поводу добавления в коллекцию - Вы предложили - а я упустил...
For i = 1To n
coll.Add 1 Next
создает n элементов = 1, хотя нам же нужно было получить уникальные... для arraylist похоже та же беда:
Set AL = CreateObject("system.collections.arraylist")
t = Timer For i = 1To n
r = Rnd
AL.Add 1 Next Debug.Print AL.Count
Без Класса - быстрее отрабатывает. Интересно выходит:
'With Class Module kluge
filling collection with 100000 random numbers took 0,2793 seconds
copying 100000 values from objects in collection Use For Each...Next to an array took 0,0371 seconds
copying 100000 values from objects in collection Use For ...Next to an array took 30,2617 seconds 'Without Class Module kluge
filling collection with 100000 random numbers took 0,0391 seconds
copying 100000 values from objects in collection Use For Each...Next to an array took 0,0156 seconds
copying 100000 values from objects in collection Use For...Next to an array took 29,4785 seconds
Получается, что Coll(i) - желательно вообще не использовать при передаче элементов коллекции в массив...
Решил добавить еще один показатель: Время проверки наличия элемента в коллекции(словаре). для коллекции придумался такой код:
Function CollectionContains1(myCol As Collection, checkVal AsVariant) AsBoolean OnErrorResumeNext
myCol.Add checkVal, CStr(checkVal) If Err Then CollectionContains1 = TrueElse myCol.Remove (CStr(checkVal)) EndFunction
Так на порядок быстрее чем:
Function CollectionContains(myCol As Collection, checkVal AsVariant) AsBoolean OnErrorResumeNext
CollectionContains = False Dim it AsVariant For Each it In myCol If it = checkVal Then
CollectionContains = True ExitFunction EndIf Next EndFunction
Для arraylist похоже нужно сделать проверку элементов, как и для обычной коллекции? Получились такие вот результаты:
test Collections, Dictionary, arraylist:
===================================================================================================
filling collection with 10 ^ 5 random numbers took 0,6719 seconds
copying 10 ^ 5 values from objects in collection Use For Each...Next to an array took 0,0078 seconds
Check1 10 ^ 5 values in collection took 1,1953 seconds
filling dictionary with 10 ^ 5 random numbers took 0,2383 seconds
keys to array dictionary 10 ^ 5 random numbers took 0,0039 seconds
sorting 10 ^ 5 random numbers in descending order with quicksort took 0,0000 seconds
filling NEW dictionary with 10 ^ 5 random numbers took 0,1523 seconds
keys to array NEW dictionary 10 ^ 5 random numbers took 0,0039 seconds
Check 10 ^ 5 values in NEW dictionary took 0,3594 seconds
filling arraylist with 10 ^ 5 random numbers took 0,3867 seconds
sorting 10 ^ 5 random numbers in ascending order with Arraylist took 0,0508 seconds
sorting 10 ^ 5 random numbers in descending order with Arraylist took 0,0508 seconds
items to array arraylist 10 ^ 5 random numbers took 0,0117 seconds