Всем привет. Прилетела мне задача помочь разобраться с отпусками. Посмотрел тут и в готовых решениях есть красивые решения, но мне не подошло. Основная особенность моей задачи была в том что нужно было разнести все даты указанные в двух ячейках: Основная часть отпуска = минимум 14дней Оставшаяся часть отпуска = остальные дни, как хочешь по одному, два ... подряд. Получается неограниченное количество диапазонов.
Поскольку я жутко ленивый, и боюсь ручных КопиПастов - эта задача подтолкнула меня сделать функцию, которая из строки с указанием диапазонов дат и дат создает полный перечень дат. Получился такой вот монстр:
[vba]
Код
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.Print UBound(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.Print UBound(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.Print Join(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.Print Join(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) End Sub Function ListDatesFromRanges_(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Boolean) As Variant
'Made by Yaroslav Popov 26/12/2017
Dim dicRanges As New Scripting.Dictionary, dicClearRanges As New Scripting.Dictionary, dicDates As New Scripting.Dictionary, tDate As Date Dim arr, arr1, i#, ii% ' Clear string, and convert to one format strListRanges = Replace(strListRanges, ",", ";") strListRanges = Replace(strListRanges, ":", "-") strListRanges = Replace(strListRanges, " ", "")
If addYear = 0 Then addYear = Year(Now) arr = Split(strListRanges, ";") For i = LBound(arr) To UBound(arr) dicRanges(Trim(arr(i))) = i Next
arr1 = dicRanges.Keys For i = LBound(arr1) To UBound(arr1) If InStr(arr1(i), ";") = 0 Then dicClearRanges(Trim(arr1(i))) = ii Next
arr1 = dicClearRanges.Keys For i = LBound(arr1) To UBound(arr1) arr = Split(arr1(i), "-") If UBound(arr) Then If Not arr(0) Like "*#.##.##*" Then arr(0) = arr(0) & "." & addYear If Not arr(1) Like "*#.##.##*" Then arr(1) = arr(1) & "." & addYear
tDate = CDate(arr(0)) Do Until tDate > CDate(arr(1)) dicDates(tDate) = i tDate = tDate + 1 Loop Else If Not arr(0) Like "*#.##.##*" Then arr(0) = arr(0) & "." & addYear dicDates(CDate(arr(0))) = i End If Next arr = dicDates.Keys If Sort_ Then QuickSort arr, LBound(arr), UBound(arr) If TypeName(Application.Caller) = "Range" Then i = Application.Caller.Cells.Count If i - 1 > UBound(arr) Then ReDim Preserve arr(i - 1) End If ListDatesFromRanges_ = arr End Function
Sub QuickSort(arr, lo As Long, hi As Long) Dim varPivot As Variant Dim varTmp As Variant Dim tmpLow As Long Dim tmpHi As Long tmpLow = lo tmpHi = hi varPivot = arr((lo + hi) \ 2) Do While tmpLow <= tmpHi Do While arr(tmpLow) < varPivot And tmpLow < hi tmpLow = tmpLow + 1 Loop Do While 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 End If Loop If lo < tmpHi Then QuickSort arr, lo, tmpHi If tmpLow < hi Then QuickSort arr, tmpLow, hi End Sub
[/vba]
Например из строки:
"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 - по умолчанию добавляется текущий год, [vba]
[/vba] Также при помощи этой функции можно легко посчитать сколько же по факту уникальных дней находится в строке диапазонов. при помощи простого Счёт [vba]
Диапазоны дат с-по - через "-" или ":" .Например : "07.10-09.10" = 07.10, 08.10, 09.10 Несвязные даты - через "," или ";" .Например : "07.10;09.10" = 07.10, 09.10
В общем чтоб много не писать - остальное в файле наглядно видно. Пожелания и замечания в мягкой форме приветствуются .
Всем привет. Прилетела мне задача помочь разобраться с отпусками. Посмотрел тут и в готовых решениях есть красивые решения, но мне не подошло. Основная особенность моей задачи была в том что нужно было разнести все даты указанные в двух ячейках: Основная часть отпуска = минимум 14дней Оставшаяся часть отпуска = остальные дни, как хочешь по одному, два ... подряд. Получается неограниченное количество диапазонов.
Поскольку я жутко ленивый, и боюсь ручных КопиПастов - эта задача подтолкнула меня сделать функцию, которая из строки с указанием диапазонов дат и дат создает полный перечень дат. Получился такой вот монстр:
[vba]
Код
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.Print UBound(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.Print UBound(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.Print Join(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.Print Join(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) End Sub Function ListDatesFromRanges_(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Boolean) As Variant
'Made by Yaroslav Popov 26/12/2017
Dim dicRanges As New Scripting.Dictionary, dicClearRanges As New Scripting.Dictionary, dicDates As New Scripting.Dictionary, tDate As Date Dim arr, arr1, i#, ii% ' Clear string, and convert to one format strListRanges = Replace(strListRanges, ",", ";") strListRanges = Replace(strListRanges, ":", "-") strListRanges = Replace(strListRanges, " ", "")
If addYear = 0 Then addYear = Year(Now) arr = Split(strListRanges, ";") For i = LBound(arr) To UBound(arr) dicRanges(Trim(arr(i))) = i Next
arr1 = dicRanges.Keys For i = LBound(arr1) To UBound(arr1) If InStr(arr1(i), ";") = 0 Then dicClearRanges(Trim(arr1(i))) = ii Next
arr1 = dicClearRanges.Keys For i = LBound(arr1) To UBound(arr1) arr = Split(arr1(i), "-") If UBound(arr) Then If Not arr(0) Like "*#.##.##*" Then arr(0) = arr(0) & "." & addYear If Not arr(1) Like "*#.##.##*" Then arr(1) = arr(1) & "." & addYear
tDate = CDate(arr(0)) Do Until tDate > CDate(arr(1)) dicDates(tDate) = i tDate = tDate + 1 Loop Else If Not arr(0) Like "*#.##.##*" Then arr(0) = arr(0) & "." & addYear dicDates(CDate(arr(0))) = i End If Next arr = dicDates.Keys If Sort_ Then QuickSort arr, LBound(arr), UBound(arr) If TypeName(Application.Caller) = "Range" Then i = Application.Caller.Cells.Count If i - 1 > UBound(arr) Then ReDim Preserve arr(i - 1) End If ListDatesFromRanges_ = arr End Function
Sub QuickSort(arr, lo As Long, hi As Long) Dim varPivot As Variant Dim varTmp As Variant Dim tmpLow As Long Dim tmpHi As Long tmpLow = lo tmpHi = hi varPivot = arr((lo + hi) \ 2) Do While tmpLow <= tmpHi Do While arr(tmpLow) < varPivot And tmpLow < hi tmpLow = tmpLow + 1 Loop Do While 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 End If Loop If lo < tmpHi Then QuickSort arr, lo, tmpHi If tmpLow < hi Then QuickSort arr, tmpLow, hi End Sub
[/vba]
Например из строки:
"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 - по умолчанию добавляется текущий год, [vba]
[/vba] Также при помощи этой функции можно легко посчитать сколько же по факту уникальных дней находится в строке диапазонов. при помощи простого Счёт [vba]
Function ListDatesFromRanges(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Boolean) Dim AL As Object, i& Dim D() As Date addYear = IIf(addYear, addYear, Year(Now)) With CreateObject("Vbscript.regexp") .Pattern = "(?:(?:(\d+\.\d+)(\.\d+)*)(?:[-:](\d+\.\d+)(\.\d+)*)*)" .Global = True If Not .test(strListRanges) Then Exit Function Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim D(1) On Error Resume Next For i = 0 To 1 D(i) = .subMatches(i * 2) & IIf(IsEmpty(.subMatches(i * 2 + 1)), "." & addYear, "") Next On Error GoTo 0 Do If Not AL.Contains(D(0)) Then AL.Add D(0) D(0) = D(0) + 1 Loop While D(1) >= D(0) End With Next End With If Sort_ Then AL.Sort ListDatesFromRanges = AL.Toarray Set AL = Nothing End Function
[/vba]
Привет. Немного попаразитировал на коде
[vba]
Код
Function ListDatesFromRanges(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Boolean) Dim AL As Object, i& Dim D() As Date addYear = IIf(addYear, addYear, Year(Now)) With CreateObject("Vbscript.regexp") .Pattern = "(?:(?:(\d+\.\d+)(\.\d+)*)(?:[-:](\d+\.\d+)(\.\d+)*)*)" .Global = True If Not .test(strListRanges) Then Exit Function Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim D(1) On Error Resume Next For i = 0 To 1 D(i) = .subMatches(i * 2) & IIf(IsEmpty(.subMatches(i * 2 + 1)), "." & addYear, "") Next On Error GoTo 0 Do If Not AL.Contains(D(0)) Then AL.Add D(0) D(0) = D(0) + 1 Loop While D(1) >= D(0) End With Next End With If Sort_ Then AL.Sort ListDatesFromRanges = AL.Toarray Set AL = Nothing End Function
Отлынивая от резки новогодних салатов, тоже повыпендриваюсь, не паразитируя, но творчески заимствуя некоторые операторы у предыдущих ораторов А также наследуя традиции темы Автоматическое заполнение элементов диапазона - с переходом от диапазонов внутри текстовой строки к диапазонам таблицы и обратно с преобразованием адресов диапазонов таблицы в числовые характеристики решаемой задачи, в данном конкретном случае - в даты.
[vba]
Код
Function ListDatesFromRanges_G(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal SortByDesc As Boolean) As Variant Dim a, b, c, d(), r() Dim addr As String, full As String Dim rng As Range, cell As Range Dim i As Integer
'разбираем исходную строку, превращая ее содержимое в составной адрес диапазона таблицы For Each a In Split(Replace(Replace(strListRanges, "-", ":"), ";", ","), ",") addr = "" For Each b In Split(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(1 To rng.Cells.Count), r(1 To rng.Cells.Count)
'составляем список дат как целых чисел - номеров строк всех ячеек диапазона таблицы For Each cell In rng.Cells i = i + 1 r(i) = 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_G = d End Function
[/vba]
Третий параметр исходной сигнатуры функции - "сортировать/не сортировать" - я в своей версии убрал, так как не вижу практического смысла в неотсортированном списке дат и выдаю из функции всегда отсортированную хронологическую последовательность. А вот за направление сортировки - по возрастанию или убыванию - как раз и отвечает мой третий параметр SortByDesc (= True для сортировки по убыванию, иначе - по возрастанию).
С Новым Годом!
Отлынивая от резки новогодних салатов, тоже повыпендриваюсь, не паразитируя, но творчески заимствуя некоторые операторы у предыдущих ораторов А также наследуя традиции темы Автоматическое заполнение элементов диапазона - с переходом от диапазонов внутри текстовой строки к диапазонам таблицы и обратно с преобразованием адресов диапазонов таблицы в числовые характеристики решаемой задачи, в данном конкретном случае - в даты.
[vba]
Код
Function ListDatesFromRanges_G(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal SortByDesc As Boolean) As Variant Dim a, b, c, d(), r() Dim addr As String, full As String Dim rng As Range, cell As Range Dim i As Integer
'разбираем исходную строку, превращая ее содержимое в составной адрес диапазона таблицы For Each a In Split(Replace(Replace(strListRanges, "-", ":"), ";", ","), ",") addr = "" For Each b In Split(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(1 To rng.Cells.Count), r(1 To rng.Cells.Count)
'составляем список дат как целых чисел - номеров строк всех ячеек диапазона таблицы For Each cell In rng.Cells i = i + 1 r(i) = 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_G = d End Function
[/vba]
Третий параметр исходной сигнатуры функции - "сортировать/не сортировать" - я в своей версии убрал, так как не вижу практического смысла в неотсортированном списке дат и выдаю из функции всегда отсортированную хронологическую последовательность. А вот за направление сортировки - по возрастанию или убыванию - как раз и отвечает мой третий параметр SortByDesc (= True для сортировки по убыванию, иначе - по возрастанию).
С прошедшим всех . krosav4ig, Gustav, смотрю Ваши варианты - мозг проснулся после выходных ... и чуть не закипел .
krosav4ig, интересно - с regexp думал, но мне кажется что с ним дольше будет на большИх объемах. Есть баг: если поменять год с 2018 на 2019 - то даты 01.05.2019-05.05.2019 - 2018-го года. на сколько я понял нужно немного поправить строку [vba]
[/vba] К моему величайшему стыду про "system.collections.arraylist" и не знал. Интересно как он справится с большим количеством данных, и есть ли везде эта библиотека? В общем озадачил меня - придется изучать .
Gustav, тоже очень интересно. Использовать диапазоны, для получения списка - даже и не додумался бы. . Смущает меня (пока) два момента, которые касаются быстродействия и универсальности (просто часто использую функции для работы данными из БД): [vba]
Код
For Each cell In rng.Cells ...
[/vba] по своему опыту "cell In rng.Cells" - работает достаточно долго - как в этом случае нужно посмотреть. и [vba]
Код
With WorksheetFunction d(i) = CDate(IIf(SortByDesc, .Large(r, i), .Small(r, i))) End With
[/vba] аналогично с предыдущим - мне кажется будет тормозить на большом количестве строк. Я использую функцию не только для получения списка дат, но и для получения количества дней, поэтому сортировку делал опционной - чтобы было быстрее. В Вашей функции количество определяется в первой части функции, поэтому думаю было бы хорошо добавить вариант "ответа" фунции(количество/список), и если нужно просто количество дней, то выходить из нее, не тратя время на просчет второй части.
В общем протестирую, немного позже - отпишусь тут .
С прошедшим всех . krosav4ig, Gustav, смотрю Ваши варианты - мозг проснулся после выходных ... и чуть не закипел .
krosav4ig, интересно - с regexp думал, но мне кажется что с ним дольше будет на большИх объемах. Есть баг: если поменять год с 2018 на 2019 - то даты 01.05.2019-05.05.2019 - 2018-го года. на сколько я понял нужно немного поправить строку [vba]
[/vba] К моему величайшему стыду про "system.collections.arraylist" и не знал. Интересно как он справится с большим количеством данных, и есть ли везде эта библиотека? В общем озадачил меня - придется изучать .
Gustav, тоже очень интересно. Использовать диапазоны, для получения списка - даже и не додумался бы. . Смущает меня (пока) два момента, которые касаются быстродействия и универсальности (просто часто использую функции для работы данными из БД): [vba]
Код
For Each cell In rng.Cells ...
[/vba] по своему опыту "cell In rng.Cells" - работает достаточно долго - как в этом случае нужно посмотреть. и [vba]
Код
With WorksheetFunction d(i) = CDate(IIf(SortByDesc, .Large(r, i), .Small(r, i))) End With
[/vba] аналогично с предыдущим - мне кажется будет тормозить на большом количестве строк. Я использую функцию не только для получения списка дат, но и для получения количества дней, поэтому сортировку делал опционной - чтобы было быстрее. В Вашей функции количество определяется в первой части функции, поэтому думаю было бы хорошо добавить вариант "ответа" фунции(количество/список), и если нужно просто количество дней, то выходить из нее, не тратя время на просчет второй части.
В общем протестирую, немного позже - отпишусь тут .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. Закомментировал эту сортировку, придав окончанию своей функции следующий вид: [vba]
Код
'составляем список дат как целых чисел - номеров строк всех ячеек диапазона таблицы 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 End Function
[/vba] Получил такие результаты на своем компутере: [vba]
Код
ДО комментирования сортировки: Slavick: 1,0625 Gustav: 7,3359 krosav4ig: 3,6641
ПОСЛЕ комментирования сортировки: Slavick: 1,0781 Gustav: 0,4063 krosav4ig: 3,5391
у Gustav, притормаживает из-за работы с диапазонами и функцией Large/Small
ТОЛЬКО из-за Large/Small. Закомментировал эту сортировку, придав окончанию своей функции следующий вид: [vba]
Код
'составляем список дат как целых чисел - номеров строк всех ячеек диапазона таблицы 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 End Function
[/vba] Получил такие результаты на своем компутере: [vba]
Код
ДО комментирования сортировки: 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" - причины расследую... поэтому сравнивал только две процедуры: [vba]
А у меня Вы сортировку не отключали? Дома решил посмотреть на ноутбуке(win10 office 2016*64) - код krosav4ig не запустился- выдало "Automation Error" - причины расследую... поэтому сравнивал только две процедуры: [vba]
Здравствуйте! Можно тоже попробовать/попаразитировать?
[vba]
Код
Function ListDatesFromRanges_Nilem(ByVal strListRanges As String, _ Optional ByVal addYear As Long, _ Optional ByVal SortBy As Long) As Variant 'SortBy: 1 - по возрастанию, 2 - по убыванию Dim a, sp, dtB As Date, dtE As Date strListRanges = Replace(strListRanges, ";", ",")
With CreateObject("System.Collections.ArrayList") For Each a In Split(strListRanges, ",") sp = Split(a, "-") dtB = CDate(sp(0)): dtE = CDate(sp(UBound(sp)))
If addYear > 0 Then dtB = DateSerial(addYear, Month(dtB), Day(dtB)) dtE = DateSerial(addYear, Month(dtE), Day(dtE)) End If
Do If Not .Contains(dtB) Then .Add dtB dtB = dtB + 1 Loop Until dtB > dtE Next a
If IsMissing(SortBy) Then Else If SortBy > 0 Then .Sort If SortBy > 1 Then .Reverse End If ListDatesFromRanges_Nilem = .toarray End With End Function
[/vba]
upd или так:
[vba]
Код
Function ListDatesFromRanges_Nilem(ByVal strListRanges As String, _ Optional ByVal addYear As Long, _ Optional ByVal SortBy As Boolean) As Variant Dim a, sp, dtB As Date, dtE As Date Dim y(), i& strListRanges = Replace(strListRanges, ";", ",")
On Error Resume Next With New Collection For Each a In Split(strListRanges, ",") sp = Split(a, "-") dtB = CDate(sp(0)): dtE = CDate(sp(UBound(sp)))
If addYear > 0 Then dtB = DateSerial(addYear, Month(dtB), Day(dtB)) dtE = DateSerial(addYear, Month(dtE), Day(dtE)) End If
Do .Add dtB, CStr(dtB) dtB = dtB + 1 Loop Until dtB > dtE Next a On Error GoTo 0
ReDim y(1 To .Count) For i = 1 To .Count y(i) = .Item(i) Next i End With
If SortBy Then y = ShellSort11(y) ListDatesFromRanges_Nilem = y() End Function
Function ShellSort11(x) '*** для 1-мерного массива Dim Limit As Long, Switch As Long, i As Long, j As Long Dim tmp j = (UBound(x) - LBound(x) + 1) \ 2 Do While j > 0 Limit = UBound(x) - j Do Switch = LBound(x) - 1 For i = LBound(x) To Limit If x(i) > x(i + j) Then 'по возрастанию ' If x(i) < x(i + j) Then 'по убыванию tmp = x(i): x(i) = x(i + j) x(i + j) = tmp: Switch = i End If Next Limit = Switch - j Loop While Switch >= LBound(x) j = j \ 2 Loop ShellSort11 = x End Function
[/vba]
Здравствуйте! Можно тоже попробовать/попаразитировать?
[vba]
Код
Function ListDatesFromRanges_Nilem(ByVal strListRanges As String, _ Optional ByVal addYear As Long, _ Optional ByVal SortBy As Long) As Variant 'SortBy: 1 - по возрастанию, 2 - по убыванию Dim a, sp, dtB As Date, dtE As Date strListRanges = Replace(strListRanges, ";", ",")
With CreateObject("System.Collections.ArrayList") For Each a In Split(strListRanges, ",") sp = Split(a, "-") dtB = CDate(sp(0)): dtE = CDate(sp(UBound(sp)))
If addYear > 0 Then dtB = DateSerial(addYear, Month(dtB), Day(dtB)) dtE = DateSerial(addYear, Month(dtE), Day(dtE)) End If
Do If Not .Contains(dtB) Then .Add dtB dtB = dtB + 1 Loop Until dtB > dtE Next a
If IsMissing(SortBy) Then Else If SortBy > 0 Then .Sort If SortBy > 1 Then .Reverse End If ListDatesFromRanges_Nilem = .toarray End With End Function
[/vba]
upd или так:
[vba]
Код
Function ListDatesFromRanges_Nilem(ByVal strListRanges As String, _ Optional ByVal addYear As Long, _ Optional ByVal SortBy As Boolean) As Variant Dim a, sp, dtB As Date, dtE As Date Dim y(), i& strListRanges = Replace(strListRanges, ";", ",")
On Error Resume Next With New Collection For Each a In Split(strListRanges, ",") sp = Split(a, "-") dtB = CDate(sp(0)): dtE = CDate(sp(UBound(sp)))
If addYear > 0 Then dtB = DateSerial(addYear, Month(dtB), Day(dtB)) dtE = DateSerial(addYear, Month(dtE), Day(dtE)) End If
Do .Add dtB, CStr(dtB) dtB = dtB + 1 Loop Until dtB > dtE Next a On Error GoTo 0
ReDim y(1 To .Count) For i = 1 To .Count y(i) = .Item(i) Next i End With
If SortBy Then y = ShellSort11(y) ListDatesFromRanges_Nilem = y() End Function
Function ShellSort11(x) '*** для 1-мерного массива Dim Limit As Long, Switch As Long, i As Long, j As Long Dim tmp j = (UBound(x) - LBound(x) + 1) \ 2 Do While j > 0 Limit = UBound(x) - j Do Switch = LBound(x) - 1 For i = LBound(x) To Limit If x(i) > x(i + j) Then 'по возрастанию ' If x(i) < x(i + j) Then 'по убыванию tmp = x(i): x(i) = x(i + j) x(i + j) = tmp: Switch = i End If Next Limit = Switch - j Loop While Switch >= LBound(x) j = j \ 2 Loop ShellSort11 = x End Function
отчего же нельзя? . будет время - докину в сравнение. Но сразу скажу что когда-то тестировал скорость словаря и коллекции - словарь победил + там есть выгрузка ключей сразу в массив.(это я про второй вариант) И сортировку, как придумал Gustav, - наверное нужно переделать(и мне) опционно по убыванию или возрастанию - для универсальности.
отчего же нельзя? . будет время - докину в сравнение. Но сразу скажу что когда-то тестировал скорость словаря и коллекции - словарь победил + там есть выгрузка ключей сразу в массив.(это я про второй вариант) И сортировку, как придумал Gustav, - наверное нужно переделать(и мне) опционно по убыванию или возрастанию - для универсальности.SLAVICK
то ли у мну моск еще не очухался то ли че-то тут не то...
[vba]
Код
Sub test() Dim AL As Object, Dic As Object, Coll As Collection, t#, r# Dim Al1 As Object Dim Arr() Randomize Set AL = CreateObject("system.collections.arraylist") t = Timer For i = 1 To 10 ^ 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 = 1 To 10 ^ 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 = 1 To 10 ^ 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" End Sub
[/vba]
[vba]
Код
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
[/vba]
Добавил сортировку по убыванию
[vba]
Код
'Sort_ ' 0: without sorting ' 1: sort in ascending order ' 2: sort in descending order Function ListDatesFromRanges_krosav4ig(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Byte = 0) Dim AL As Object, i&, Match Dim d() As Date strListRanges = ";" & strListRanges & ";" addYear = IIf(addYear, addYear, Year(Now)) With CreateObject("Vbscript.regexp") .Pattern = "((?:(\d+\.\d+)(\.\d+)*)(?:[- :]*(\d+\.\d+)(\.\d+)*)*[;, ]*)(?!.*[;, ]*\1[;,]*)" 'на всяк случай сделал выборку уникальных диапазонов дат .Global = True If Not .Test(strListRanges) Then Exit Function Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim d(1) On Error Resume Next For i = 1 To 2 d(i - 1) = .subMatches(i * 2 - 1) & IIf(IsEmpty(.subMatches(i * 2)), "." & addYear, .subMatches(i * 2)) Next On Error GoTo 0 Do If Not AL.Contains(d(0)) Then AL.Add d(0) d(0) = d(0) + 1 Loop While d(1) >= d(0) End With Next End With If Sort_ Then AL.Sort If Sort_ = 2 Then AL.Reverse ListDatesFromRanges_krosav4ig = AL.toarray Set AL = Nothing End Function
то ли у мну моск еще не очухался то ли че-то тут не то...
[vba]
Код
Sub test() Dim AL As Object, Dic As Object, Coll As Collection, t#, r# Dim Al1 As Object Dim Arr() Randomize Set AL = CreateObject("system.collections.arraylist") t = Timer For i = 1 To 10 ^ 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 = 1 To 10 ^ 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 = 1 To 10 ^ 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" End Sub
[/vba]
[vba]
Код
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
[/vba]
Добавил сортировку по убыванию
[vba]
Код
'Sort_ ' 0: without sorting ' 1: sort in ascending order ' 2: sort in descending order Function ListDatesFromRanges_krosav4ig(ByVal strListRanges As String, Optional ByVal addYear&, Optional ByVal Sort_ As Byte = 0) Dim AL As Object, i&, Match Dim d() As Date strListRanges = ";" & strListRanges & ";" addYear = IIf(addYear, addYear, Year(Now)) With CreateObject("Vbscript.regexp") .Pattern = "((?:(\d+\.\d+)(\.\d+)*)(?:[- :]*(\d+\.\d+)(\.\d+)*)*[;, ]*)(?!.*[;, ]*\1[;,]*)" 'на всяк случай сделал выборку уникальных диапазонов дат .Global = True If Not .Test(strListRanges) Then Exit Function Set AL = CreateObject("system.collections.arraylist") For Each Match In .Execute(strListRanges) With Match ReDim d(1) On Error Resume Next For i = 1 To 2 d(i - 1) = .subMatches(i * 2 - 1) & IIf(IsEmpty(.subMatches(i * 2)), "." & addYear, .subMatches(i * 2)) Next On Error GoTo 0 Do If Not AL.Contains(d(0)) Then AL.Add d(0) d(0) = d(0) + 1 Loop While d(1) >= d(0) End With Next End With If Sort_ Then AL.Sort If Sort_ = 2 Then AL.Reverse ListDatesFromRanges_krosav4ig = AL.toarray Set AL = Nothing End Function
Вы не рассчитали этот ОЧЕНЬ важный показатель . а он у коллекции жутко тормозит - она не любит отдавать данные . Я попаразитировал на Вашем коде и добавил пару показателей..
[vba]
Код
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 As New Scripting.Dictionary t = Timer For i = 1 To 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(1 To Coll.Count) For i = 1 To 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
[/vba]
Весь код не влазит в сообщение - поэтому только то что добавил. Потом протестировал на 10^5 и 10^6 - получились такие результаты:
[vba]
Код
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
[/vba]
[vba]
Код
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
[/vba]
Дождатся завершения items to array NEW collection - не смог, поэтому остановил код на 235734, и это заняло у моего ноута 1026с Странно, что на 10^5 - показатели словаря лучше чем у arraylist, а при 10^6 - значительно хуже По поводу работы со словарем: есть несколько тонкостей, которые улучшают работу с ним: можно писать не [vba]
Код
DIC.Add r, r
[/vba] а [vba]
Код
DIC(r) = 1
[/vba]этого достаточно для создания словаря без ошибок, если нам нужны просто уникальные значения, без айтемов.
вместо [vba]
Код
Set Dic = CreateObject("scripting.dictionary")
[/vba]лучше подключить библиотеку и использовать : [vba]
Код
Dim DIC_NEW As New Scripting.Dictionary
[/vba] Тогда будет быстрее работать + сразу подсказки вылазят - удобно .
Вы не рассчитали этот ОЧЕНЬ важный показатель . а он у коллекции жутко тормозит - она не любит отдавать данные . Я попаразитировал на Вашем коде и добавил пару показателей..
[vba]
Код
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 As New Scripting.Dictionary t = Timer For i = 1 To 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(1 To Coll.Count) For i = 1 To 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
[/vba]
Весь код не влазит в сообщение - поэтому только то что добавил. Потом протестировал на 10^5 и 10^6 - получились такие результаты:
[vba]
Код
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
[/vba]
[vba]
Код
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
[/vba]
Дождатся завершения items to array NEW collection - не смог, поэтому остановил код на 235734, и это заняло у моего ноута 1026с Странно, что на 10^5 - показатели словаря лучше чем у arraylist, а при 10^6 - значительно хуже По поводу работы со словарем: есть несколько тонкостей, которые улучшают работу с ним: можно писать не [vba]
Код
DIC.Add r, r
[/vba] а [vba]
Код
DIC(r) = 1
[/vba]этого достаточно для создания словаря без ошибок, если нам нужны просто уникальные значения, без айтемов.
вместо [vba]
Код
Set Dic = CreateObject("scripting.dictionary")
[/vba]лучше подключить библиотеку и использовать : [vba]
Код
Dim DIC_NEW As New Scripting.Dictionary
[/vba] Тогда будет быстрее работать + сразу подсказки вылазят - удобно .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 = 1 To 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(1 To 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" End Sub
[/vba]
[vba]
Код
Private Val As Variant Public Property Get Self(v) Val = v Set Self = Me End Property Public Property Get Value() Value = Val End Property
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 = 1 To 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(1 To 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" End Sub
[/vba]
[vba]
Код
Private Val As Variant Public Property Get Self(v) Val = v Set Self = Me End Property Public Property Get Value() Value = Val End Property
Sub testALLWithoutKluge() Dim coll As Collection, n& Dim AL As Object, Dic As Object, t#, r# Dim Al1 As Object Dim arr() n = 10 ^ 6 Randomize ' ======Collections================================== Set coll = New Collection On Error Resume Next t = Timer For i = 1 To 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 On Error Resume Next t = Timer For i = 1 To 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" End Sub
[/vba] это по поводу добавления в коллекцию - Вы предложили - а я упустил... [vba]
Код
For i = 1 To n coll.Add 1 Next
[/vba] создает n элементов = 1, хотя нам же нужно было получить уникальные... для arraylist похоже та же беда: [vba]
Код
Set AL = CreateObject("system.collections.arraylist") t = Timer For i = 1 To n r = Rnd AL.Add 1 Next Debug.Print AL.Count
Без Класса - быстрее отрабатывает. Интересно выходит: [vba]
Код
'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
[/vba]
Получается, что Coll(i) - желательно вообще не использовать при передаче элементов коллекции в массив...
Решил добавить еще один показатель: Время проверки наличия элемента в коллекции(словаре). для коллекции придумался такой код: [vba]
Код
Function CollectionContains1(myCol As Collection, checkVal As Variant) As Boolean On Error Resume Next myCol.Add checkVal, CStr(checkVal) If Err Then CollectionContains1 = True Else myCol.Remove (CStr(checkVal)) End Function
[/vba] Так на порядок быстрее чем: [vba]
Код
Function CollectionContains(myCol As Collection, checkVal As Variant) As Boolean On Error Resume Next CollectionContains = False Dim it As Variant For Each it In myCol If it = checkVal Then CollectionContains = True Exit Function End If Next End Function
[/vba] Для arraylist похоже нужно сделать проверку элементов, как и для обычной коллекции? Получились такие вот результаты:
[vba]
Код
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 As Object, Dic As Object, t#, r# Dim Al1 As Object Dim arr() n = 10 ^ 6 Randomize ' ======Collections================================== Set coll = New Collection On Error Resume Next t = Timer For i = 1 To 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 On Error Resume Next t = Timer For i = 1 To 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" End Sub
[/vba] это по поводу добавления в коллекцию - Вы предложили - а я упустил... [vba]
Код
For i = 1 To n coll.Add 1 Next
[/vba] создает n элементов = 1, хотя нам же нужно было получить уникальные... для arraylist похоже та же беда: [vba]
Код
Set AL = CreateObject("system.collections.arraylist") t = Timer For i = 1 To n r = Rnd AL.Add 1 Next Debug.Print AL.Count
Без Класса - быстрее отрабатывает. Интересно выходит: [vba]
Код
'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
[/vba]
Получается, что Coll(i) - желательно вообще не использовать при передаче элементов коллекции в массив...
Решил добавить еще один показатель: Время проверки наличия элемента в коллекции(словаре). для коллекции придумался такой код: [vba]
Код
Function CollectionContains1(myCol As Collection, checkVal As Variant) As Boolean On Error Resume Next myCol.Add checkVal, CStr(checkVal) If Err Then CollectionContains1 = True Else myCol.Remove (CStr(checkVal)) End Function
[/vba] Так на порядок быстрее чем: [vba]
Код
Function CollectionContains(myCol As Collection, checkVal As Variant) As Boolean On Error Resume Next CollectionContains = False Dim it As Variant For Each it In myCol If it = checkVal Then CollectionContains = True Exit Function End If Next End Function
[/vba] Для arraylist похоже нужно сделать проверку элементов, как и для обычной коллекции? Получились такие вот результаты:
[vba]
Код
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