Здравствуйте! Разбирался с функцией РАБДЕНЬ, возникла необходимость написания данной функции на чистом VBA без использования дополнительных формул и диапазонов на рабочих листах книги. Выкладываю свой вариант для закидывания тапками, может кому пригодится. Можно разместить в личной книге макросов или надстройке. В конце года после выхода постановления Правительства РФ необходимо добавлять в код данные по праздничным и выходным дням, а также по рабочим субботам (внесены данные с 01.01.2015 по текущий год).
Скрытый текст
Код
<…>Function fnСледующийРабочийДень(ByVal dДень As Date, _
Optional ByVal iДобавитьДней As Integer = 1) As Date
If iДобавитьДней > 0 Then
Do While iДобавитьДней > 0
If fnЭтоРабочийДень(dДень + 1) Then
iДобавитьДней = iДобавитьДней - 1
End If
dДень = dДень + 1
Loop
Else
Do While iДобавитьДней < 0
If fnЭтоРабочийДень(dДень - 1) Then
iДобавитьДней = iДобавитьДней + 1
End If
dДень = dДень - 1
Loop
End If
fnСледующийРабочийДень = dДень
End Function
Private Function fnЭтоРабочийДень(ByVal dДень As Date) As Boolean
If Weekday(dДень, vbMonday) <> 6 And Weekday(dДень, vbMonday) <> 7 _
And Not fnЭтоПраздникИлиВыходной(dДень) Or fnЭтоРабочаяСуббота(dДень) Then
fnЭтоРабочийДень = True
Else
fnЭтоРабочийДень = False
End If
End Function
Private Function fnЭтоПраздникИлиВыходной(dДень As Date) As Boolean
Dim arrПраздВых(), i As Long
'Комментарий ниже для примера, какие даты учтены.
'01.01.2015, 02.01.2015, 03.01.2015, 04.01.2015, 05.01.2015, 06.01.2015, 07.01.2015, 08.01.2015, 09.01.2015, 23.02.2015, 08.03.2015,
'01.05.2015, 04.05.2015, 09.05.2015, 11.05.2015, 12.06.2015, 04.11.2015, 01.01.2016, 02.01.2016, 03.01.2016, 04.01.2016, 05.01.2016,
'06.01.2016, 07.01.2016, 08.01.2016, 22.02.2016, 23.02.2016, 07.03.2016, 08.03.2016, 01.05.2016, 02.05.2016, 03.05.2016, 09.05.2016,
'12.06.2016, 13.06.2016, 04.11.2016, 01.01.2017, 02.01.2017, 03.01.2017, 04.01.2017, 05.01.2017, 06.01.2017, 07.01.2017, 08.01.2017,
'23.02.2017, 24.02.2017, 08.03.2017, 01.05.2017, 08.05.2017, 09.05.2017, 12.06.2017, 04.11.2017, 06.11.2017, 01.01.2018, 02.01.2018,
'03.01.2018, 04.01.2018, 05.01.2018, 06.01.2018, 07.01.2018, 08.01.2018, 23.02.2018, 08.03.2018, 09.03.2018, 30.04.2018, 01.05.2018,
'02.05.2018, 09.05.2018, 11.06.2018, 12.06.2018, 04.11.2018, 31.12.2018, 01.01.2019, 02.01.2019, 03.01.2019, 04.01.2019, 05.01.2019,
'06.01.2019, 07.01.2019, 08.01.2019, 23.02.2019, 08.03.2019, 01.05.2019, 02.05.2019, 03.05.2019, 09.05.2019, 10.05.2019, 12.06.2019,
'04.11.2019, 01.01.2020, 02.01.2020, 03.01.2020, 04.01.2020, 05.01.2020, 06.01.2020, 07.01.2020, 08.01.2020, 23.02.2020, 24.02.2020,
'08.03.2020, 09.03.2020, 01.05.2020, 04.05.2020, 05.05.2020, 09.05.2020, 11.05.2020, 12.06.2020, 04.11.2020, 01.01.2021, 02.01.2021,
'03.01.2021, 04.01.2021, 05.01.2021, 06.01.2021, 07.01.2021, 08.01.2021, 23.02.2021, 08.03.2021, 01.05.2021, 09.05.2021, 12.06.2021,
'04.11.2021
'В массив ниже добавить нужные даты праздничных и выходных дней.
arrПраздВых = Array(42005, 42006, 42007, 42008, 42009, 42010, 42011, 42012, 42013, 42058, 42071, 42125, 42128, 42133, 42135, _
42167, 42312, 42370, 42371, 42372, 42373, 42374, 42375, 42376, 42377, 42422, 42423, 42436, 42437, 42491, 42492, 42493, 42499, _
42533, 42534, 42678, 42736, 42737, 42738, 42739, 42740, 42741, 42742, 42743, 42789, 42790, 42802, 42856, 42863, 42864, 42898, _
43043, 43045, 43101, 43102, 43103, 43104, 43105, 43106, 43107, 43108, 43154, 43167, 43168, 43220, 43221, 43222, 43229, 43262, _
43263, 43408, 43465, 43466, 43467, 43468, 43469, 43470, 43471, 43472, 43473, 43519, 43532, 43586, 43587, 43588, 43594, 43595, _
43628, 43773, 43831, 43832, 43833, 43834, 43835, 43836, 43837, 43838, 43884, 43885, 43898, 43899, 43952, 43955, 43956, 43960, _
43962, 43994, 44139, 44197, 44198, 44199, 44200, 44201, 44202, 44203, 44204, 44250, 44263, 44317, 44325, 44359, 44504)
For i = LBound(arrПраздВых) To UBound(arrПраздВых)
If CLng(dДень) = arrПраздВых(i) Then
fnЭтоПраздникИлиВыходной = True
Exit Function
End If
Next i
fnЭтоПраздникИлиВыходной = False
End Function
Private Function fnЭтоРабочаяСуббота(dДень As Date) As Boolean
Dim arrРабСуб(), i As Long
'Комментарий ниже для примера, какие даты учтены.
'20.06.2016, 28.04.2018, 09.06.2018, 29.12.2018
'В массив ниже добавить нужные даты рабочих суббот.
arrРабСуб = Array(42541, 43218, 43260, 43463)
For i = LBound(arrРабСуб) To UBound(arrРабСуб)
If CLng(dДень) = arrРабСуб(i) Then
fnЭтоРабочаяСуббота = True
Exit Function
End If
Next i
fnЭтоРабочаяСуббота = False
End Function<…>
aequit, здравствуйте! Если выкладываете код, то желательно размещать его не только в файле, но и в сообщении (сначала оформить тэгом <…> и под спойлер SP)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Тоже такое делал, но что по мне, то более userfriendly делать именно с возможностью указания диапазонов праздников и рабочих суббот(я делал через именованные диапазоны), т.к. в разных компаниях эти даты могут отличаться.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
День добрый. Для раскрытия темы выходных дней - во вложении макрос собирающий все выходные дни из Консультанского производственного календаря. Каждый год скачиваю календарь в doc формате, дергаю даты, потом уже использую всевозможные формулы.
Сейчас появился еще один вариант, используя веб-запрос, дажеR пакет сделали с его использованием. Но пока непонятно как быстро и как долго будут обновлять данные о выходных днях.
egonomist написал: во вложении макрос собирающий все выходные дни
Спасибо, работает (только предварительно нужно создать в книге лист с именем "temp", иначе макрос вываливается в ошибку. В данном варианте можно обойтись без отдельного списка рабочих суббот, так как после работы макроса в массиве "всех выходных" просто не оказывается рабочих суббот (проверил на 09.06.2018 и 29.12.2018). Также можно исключить проверку на субботы и воскресенья, так как ВСЕ даты, не входящие в список, будут рабочими.
aequit, Вместо цикла по массиву праздников, загоняем список в словарь. Метод Exists позволит проверить наличие даты в словаре сильно быстрее. Можно пойти далее и держать словарь в памяти, чтобы не создавать его для каждого вызова функции - будет совсем круто
можно сделать этот аргумент-диапазон опциональным и, если он не указан, то использовать встроенный справочник, а если указан, то заменить/дополнить список. Типа компромисс. Но за каждый такой компромисс придётся расплачиваться скоростью…
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous написал: Вместо цикла по массиву праздников, загоняем список в словарь. Метод Exists позволит проверить наличие даты в словаре сильно быстрее. Можно пойти далее и держать словарь в памяти, чтобы не создавать его для каждого вызова функции - будет совсем круто
Сделал.
Цитата
Jack Famous написал: сделать этот аргумент-диапазон опциональным и, если он не указан, то использовать встроенный справочник, а если указан, то заменить/дополнить список. Типа компромисс.
Сделал.
Скрытый текст
Код
'aequit 18.01.2020
Function fnСледующийРабочийДень(ByVal dДень As Date, _
Optional ByVal iДобавитьДней As Integer = 1) As Date
If iДобавитьДней > 0 Then
Do While iДобавитьДней > 0
If fnЭтоРабочийДень(dДень + 1) Then
iДобавитьДней = iДобавитьДней - 1
End If
dДень = dДень + 1
Loop
Else
Do While iДобавитьДней < 0
If fnЭтоРабочийДень(dДень - 1) Then
iДобавитьДней = iДобавитьДней + 1
End If
dДень = dДень - 1
Loop
End If
fnСледующийРабочийДень = dДень
End Function
Function fnЭтоРабочийДень(ByVal dДень As Date) As Boolean
If dДень = 0 Then Exit Function
If Weekday(dДень, vbMonday) <> 6 And Weekday(dДень, vbMonday) <> 7 _
And Not fnЭтоПраздникИлиВыходной(dДень) Or fnЭтоРабочаяСуббота(dДень) Then
fnЭтоРабочийДень = True
Else
fnЭтоРабочийДень = False
End If
End Function
Private Function fnЭтоПраздникИлиВыходной(dДень As Date) As Boolean
Dim arrПраздВых(), i As Long
Dim iRow As Integer, varTmp
'Dim objDicHolidays As Dictionary 'Время тестирования на заполнение формулой и вычисление 500000 ячеек - 275,9766 секунд.
Static objDicHolidays As Dictionary 'Время тестирования на заполнение формулой и вычисление 500000 ячеек - 8,296875 секунд.
If objDicHolidays Is Nothing Then
Set objDicHolidays = New Dictionary
'Если существует именованный диапазон "НерабочиеДни", добавляем его содержимое в словарь.
If TypeOf Evaluate("НерабочиеДни") Is Range Then
With Range("НерабочиеДни")
For iRow = 1 To .Rows.Count
varTmp = objDicHolidays.Item(CLng(.Cells(iRow, 1).Value))
Next iRow
End With
End If
'Вне зависимости от наличия и состава диапазона "НерабочиеДни" добавляем в словарь содержимое массива.
'Совпадения перезаписываются. Будут добавлены коды дат:
'с 01.01.2006 по 31.12.2020, а также постоянные праздничные дни по ТК с 01.01.2021 по 31.12.2036 (c 09.01.2021 закомментировано).
'В массив ниже добавить (при необходимости) нужные даты праздничных и дополнительных выходных дней.
arrПраздВых = Array(38718, 38719, 38720, 38721, 38722, 38723, 38724, 38725, 38726, 38771, 38772, 38784, 38838, 38845, 38846, 38880, 39025, 39027, 39083, 39084, 39085, 39086, 39087, 39088, 39089, 39090, 39136, _
39149, 39202, 39203, 39211, 39244, 39245, 39390, 39391, 39447, 39448, 39449, 39450, 39451, 39452, 39453, 39454, 39455, 39501, 39503, 39515, 39517, 39569, 39570, 39577, 39611, 39612, 39755, 39756, 39814, 39815, _
39816, 39817, 39818, 39819, 39820, 39821, 39822, 39867, 39880, 39881, 39934, 39942, 39944, 39976, 40121, 40179, 40180, 40181, 40182, 40183, 40184, 40185, 40186, 40231, 40232, 40245, 40299, 40301, 40307, 40308, _
40341, 40343, 40486, 40487, 40544, 40545, 40546, 40547, 40548, 40549, 40550, 40551, 40553, 40597, 40609, 40610, 40664, 40665, 40672, 40706, 40707, 40851, 40909, 40910, 40911, 40912, 40913, 40914, 40915, 40916, _
40917, 40962, 40976, 40977, 41029, 41030, 41036, 41037, 41038, 41071, 41072, 41217, 41218, 41274, 41275, 41276, 41277, 41278, 41279, 41280, 41281, 41282, 41328, 41341, 41395, 41396, 41397, 41403, 41404, 41437, _
41582, 41640, 41641, 41642, 41643, 41644, 41645, 41646, 41647, 41693, 41706, 41708, 41760, 41761, 41768, 41802, 41803, 41946, 41947, 42005, 42006, 42007, 42008, 42009, 42010, 42011, 42012, 42013, 42058, 42071, _
42072, 42125, 42128, 42133, 42135, 42167, 42312, 42370, 42371, 42372, 42373, 42374, 42375, 42376, 42377, 42422, 42423, 42436, 42437, 42491, 42492, 42493, 42499, 42533, 42534, 42678, 42736, 42737, 42738, 42739, _
42740, 42741, 42742, 42743, 42789, 42790, 42802, 42856, 42863, 42864, 42898, 43043, 43045, 43101, 43102, 43103, 43104, 43105, 43106, 43107, 43108, 43154, 43167, 43168, 43221, 43222, 43229, 43263, 43408, 43409, _
43465, 43466, 43467, 43468, 43469, 43470, 43471, 43472, 43473, 43519, 43532, 43586, 43587, 43588, 43594, 43595, 43628, 43773, 43831, 43832, 43833, 43834, 43835, 43836, 43837, 43838, 43884, 43885, 43898, 43899, _
43952, 43955, 43956, 43960, 43962, 43994, 44139, 44197, 44198, 44199, 44200, 44201, 44202, 44203, 44204) ', 44250, 44263, 44317, 44325, 44359, 44504, 44562, 44563, 44564, 44565, 44566, 44567, 44568, 44569, 44615, _
44628, 44682, 44690, 44724, 44869, 44927, 44928, 44929, 44930, 44931, 44932, 44933, 44934, 44980, 44993, 45047, 45055, 45089, 45234, 45292, 45293, 45294, 45295, 45296, 45297, 45298, 45299, 45345, 45359, 45413, _
45421, 45455, 45600, 45658, 45659, 45660, 45661, 45662, 45663, 45664, 45665, 45711, 45724, 45778, 45786, 45820, 45965, 46023, 46024, 46025, 46026, 46027, 46028, 46029, 46030, 46076, 46089, 46143, 46151, 46185, _
46330, 46388, 46389, 46390, 46391, 46392, 46393, 46394, 46395, 46441, 46454, 46508, 46516, 46550, 46695, 46753, 46754, 46755, 46756, 46757, 46758, 46759, 46760, 46806, 46820, 46874, 46882, 46916, 47061, 47119, _
47120, 47121, 47122, 47123, 47124, 47125, 47126, 47172, 47185, 47239, 47247, 47281, 47426, 47484, 47485, 47486, 47487, 47488, 47489, 47490, 47491, 47537, 47550, 47604, 47612, 47646, 47791, 47849, 47850, 47851, _
47852, 47853, 47854, 47855, 47856, 47902, 47915, 47969, 47977, 48011, 48156, 48214, 48215, 48216, 48217, 48218, 48219, 48220, 48221, 48267, 48281, 48335, 48343, 48377, 48522, 48580, 48581, 48582, 48583, 48584, _
48585, 48586, 48587, 48633, 48646, 48700, 48708, 48742, 48887, 48945, 48946, 48947, 48948, 48949, 48950, 48951, 48952, 48998, 49011, 49065, 49073, 49107, 49252, 49310, 49311, 49312, 49313, 49314, 49315, 49316, _
49317, 49363, 49376, 49430, 49438, 49472, 49617, 49675, 49676, 49677, 49678, 49679, 49680, 49681, 49682, 49728, 49742, 49796, 49804, 49838, 49983)
For i = LBound(arrПраздВых) To UBound(arrПраздВых)
varTmp = objDicHolidays.Item(arrПраздВых(i))
Next i
End If
fnЭтоПраздникИлиВыходной = objDicHolidays.Exists(CLng(dДень))
End Function
Private Function fnЭтоРабочаяСуббота(dДень As Date) As Boolean
Dim arrРабСуб(), i As Long
Dim iRow As Integer, varTmp
Static objDicWorkingSaturdays As Dictionary
If objDicWorkingSaturdays Is Nothing Then
Set objDicWorkingSaturdays = New Dictionary
If TypeOf Evaluate("РабочиеСубботы") Is Range Then
With Range("РабочиеСубботы")
For iRow = 1 To .Rows.Count
varTmp = objDicWorkingSaturdays.Item(CLng(.Cells(iRow, 1).Value))
Next iRow
End With
End If
End If
'Вне зависимости от наличия и состава диапазона "РабочиеСубботы" добавляем в словарь содержимое массива.
'Совпадения перезаписываются. Будут добавлены коды дат рабочих суббот или воскресений с 01.01.2006 по 31.12.2020.
'В массив ниже добавить (при необходимости) нужные даты рабочих суббот или воскресений.
arrРабСуб = Array(38774, 39200, 39242, 39445, 39572, 39606, 39753, 39824, 40236, 40495, _
40607, 40979, 41027, 41034, 41041, 41069, 41272, 42420, 43218, 43260, 43463)
For i = LBound(arrРабСуб) To UBound(arrРабСуб)
varTmp = objDicWorkingSaturdays.Item(arrРабСуб(i))
Next i
fnЭтоРабочаяСуббота = objDicWorkingSaturdays.Exists(CLng(dДень))
End Function
Цитата
Jack Famous написал: Но за каждый такой компромисс придётся расплачиваться скоростью…
Измерил скорость работы путём заполнения формулой с функцией 500000 ячеек в столбце (при этом происходил её расчёт в каждой ячейке) . Результаты: 8,296875 секунд, если держать словарь в памяти. 275,9766 секунд, если создавать его для каждого вызова функции. Ускорение более, чем в 33 раза. В старом варианте функции из вчерашнего поста, при переборе элементов массива (без словаря) - 61,625 секунд.
aequit, рад, что помогло Если заменить функцию рабочего листа на обработку внутри процедуры с последующей вставкой на лист, то будет ещё заметно быстрее
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Доброго времени суток, а можно ли как-то подсчитать рабочее время, например рабочий день с 8 до 18, я изначально делал это формулой, вроде считает, но потом когда к четвергу прибавляется два, три дня, он не переносит на понедельник, а ещё может поставить время позже 18 или раньше 8
Так вот, как можно бы добавить в эту функцию ещё и счёт времени, натолкните на мысль?
lizardjazz1 написал: как можно бы добавить в эту функцию ещё и счёт времени
Непонятно, что Вы хотите получить? Попробуйте человеку, незнакомому с Вашей задачей (например, коллеге за соседним столом) дать прочитать её и потом спросите: "Понятно и доходчиво я описал требуемое?" Прибавить к двум рабочим дням 3 рабочих часа? А к какому моменты прибавлять часы? Опишите подробно и приложите пример, никто за Вас файл рисовать не будет. В файле сделайте 2 столбца со значениями, в первом исходные данные, во втором - что нужно получить. Тогда шанс получить ответ значительно возрастёт.
Еще и от региона страны. Ближайший пример: у нас в области 28 декабря 2019 года был объявлен рабочим днём, а 31 декабря 2019 года - выходным. В 2018 году дни проведения матчей чемпионата мира по футболу в нашей области были объявлены выходными днями. Всё это оперативно нужно учитывать.
да, я именно об этом если этой информации нет в исходных, ничего считать НЕ ВОЗМОЖНО, т.е. можно но без толку. поэтому задача больше на экстрасенсов, чем на людей что-то понимающих в Excel
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
aequit написал: дравствуйте!Разбирался с функцией РАБДЕНЬ, возникла необходимость написания данной функции на чистом VBA без использования дополнительных формул и диапазонов на рабочих листах книги. Выкладываю свой вариант для закидывания тапками, может кому пригодится. Можно разместить в личной книге макросов или надстройке. В конце года после выхода постановления Правительства РФ необходимо добавлять в код данные по праздничным и выходным дням, а также по рабочим субботам (внесены данные с 01.01.2015 по текущий год).
Доработал для чтения массива выходных из диапазона ячеек, но не смог победить одну проблему: При вводе значения в "iДобавитьДней" меньше единицы 0,2; 0,5; 0,8... выполняется расчет без учета остатка дня.
Так создайте свою тему, опишите, что хотите получить и приложите пример. Непонятно, что Вы хотите, рабочий день не делится на части, это уже получаются рабочие часы, возможно, нужен совсем другой алгоритм. Только недавно обсуждалась тема рабочих дней, вот вариант формулой без VBA
Подключен, разобрался, была подключена библотека вордовская которая была выше в иерархии и перехватывала dictionary. Еще вопрос, если вводимая дата - рабочий день, то функция все равно ищет ближайший рабочий?
Сергей bangoo написал: если вводимая дата - рабочий день, то функция все равно ищет ближайший рабочий?
Да, это и требуется. Кроме вводимой даты есть ещё один аргумент: количество дней. Вводим дату 19.09.2022 и количество дней - 1. Результат будет 20.09.2022 Вводим дату 19.09.2022 и количество дней - 0. Результат будет 19.09.2022
Здравствуйте. Подскажите, пожалуйста. Как переделать формулы, чтобы внесённые (перенесённые) рабочие дни, попадающие на выходные, показывались как рабочие дни?