В одном из заказов недавно столкнулся с проблемой получения праздничных дней согласно утвержденному производственному календарю. Да, я знаю, что в компаниях он может быть свой, отличный от опубликованного государством. И смысла как-то получать список праздничных дат с общедоступных порталов не было. Но вот именно сейчас потребовался именно общедоступный опубликованный календарь, чтобы можно было его автоматом скачать и применить. И оказалось, что это тоже не самая простая задача: многие календари в сети либо в формате PDF, либо в виде frame-ов по месяцам, либо вообще картинками. Только на одном сайте получилось найти файл для скачивания: https://data.gov.ru/opendata/7708660670-proizvcalendar. Но и там оказалась не сразу ссылка на готовый календарь, а описание набора, потом паспорт и уже только в паспорте набора можно найти ссылку на файл:
эта ссылка нам и нужна. И тут две проблемы:
- Набор может меняться периодически. Например, сейчас там выложен календарь от 1999 до 2025 года. Но в следующем году праздники на 2021 год могут поменяться и ссылка на набор тоже скорее всего изменится. Поэтому статичную ссылку на набор(
https://data.gov.ru/opendata/7708660670-proizvcalendar/data-20191112T1252-structure-20191112T1247.csv ) мы применить не можем - её желательно определять автоматом. - Сам файл CSV не в самом удобном формате. Там не перечень дат, а годы и месяцы в строках и столбцах, и для каждого месяца в одной ячейке перечень праздничных дат через запятую для этого месяца. При этом не всегда удачно открывается, если заранее не задать кодировку:
Поэтому без доп.преобразований тут никак не обойтись.
Для рабочего проекта я выбрал способ получения дат через VBA(для поддержки всех версий независимо от надстроек), но в связи с популярностью Power Qwery решил сделать решение и при помощи этой надстройки.
Решение использует два основных инструмента внутри Visual Basic for Application:
Я постарался в коде в некоторых местах прописать комментарии, т.к. прописывать их напрямую в статье не очень удобно - код не маленький и описывать каждый кусок проблематично и больше запутает, чем прояснит процесс, как мне кажется.
'--------------------------------------------------------------------------------------- ' Author : Дмитрий (The_Prist) Щербаков ' Профессиональная разработка приложений для MS Office любой сложности ' Проведение тренингов по MS Excel ' https://www.excel-vba.ru ' info@excel-vba.ru ' WebMoney - R298726502453; Яндекс.Деньги - 41001332272872 ' Purpose: Загрузка праздничных дат из производственного календаря с сайта data.gov.ru ' https://www.excel-vba.ru/chto-umeet-excel/proizvodstvennyj-kalendar-v-excel-vba-i-power-qwery/ '--------------------------------------------------------------------------------------- Option Explicit 'объявление функции API - URLDownloadToFile для скачивания файла 'Идет в самом начале, т.к. API функции необходимо объявлять именно здесь ' работает на любых ПК под управлением ОС Windows ' на MAC код работать не будет #If Win64 Then 'для операционных систем с 64-разрядной архитектурой Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong #Else #If VBA7 Then 'для любых операционных систем с офисом 2010 и выше Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As LongPtr #Else 'для 32-разрядных операционных систем Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _ (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long #End If #End If 'Основная процедура поиска ссылки и скачивания календаря ' в ходе работы использует остальные функции Sub LoadCalendar() Dim res, response$, surl$, sex$, sFName$, sMsg$ Dim oXMLHTTP As Object Dim lp&, le&, le2& Dim wbPrCalendar As Workbook Application.ScreenUpdating = False Err.Clear On Error GoTo err_handler 'подключаемся к сайту Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP") With oXMLHTTP .Open "GET", "https://data.gov.ru/opendata/7708660670-proizvcalendar", False .send 'ждем пока страница прогрузится Do While .readyState <> 4 DoEvents Loop 'запоминаем исходный код страницы(для поиска ссылки) response = .responseText End With If Len(response) Then 'ищем место с ссылкой на наш CSV ' их там несколько, нам нужна "Гиперссылка (URL) на набор" lp = InStr(1, response, "Гиперссылка (URL) на набор", 1) If lp > 0 Then 'если нашли - ищем начало гиперссылки для скачивания(по ключевым http) le = InStr(lp, response, "http", 1) If le > 0 Then 'если это CSV - берем его le2 = InStr(le, response, ".csv", 1) 'CSV не нашли - пробуем найти xlsx(что вряд ли, но лушче попробовать) If le2 = 0 Then le2 = InStr(le, response, ".xls", 1) End If If le2 > 0 Then 'формируем только адрес ссылки для скачивания lp = InStr(le2, response, Chr(34), 1) surl = Mid(response, le, lp - le) lp = InStrRev(surl, ".") sex = Mid(surl, lp, Len(surl) - lp + 1) 'пробуем скачать при помощи функции API Set wbPrCalendar = CallDownload(surl, "prod_cal" & sex) 'обрабатываем скачанный файл If Not wbPrCalendar Is Nothing Then wbPrCalendar.Activate sFName = wbPrCalendar.FullName 'преобразуем данные в файле в столбец дат Call FillProdCalend(wbPrCalendar) wbPrCalendar.Close 0 DoEvents On Error Resume Next 'удаляем после обработки Kill sFName Err.Clear DoEvents sMsg = "Производственный календарь успешно обновлен" End If End If End If End If End If 'если будет какая-то ошибка - код перейдет сюда и покажет текст ошибки err_handler: If Err.Number <> 0 Then sMsg = "Не удалось обновить Производственный календарь." & vbNewLine & _ "Ошибка: " & Err.Description End If Application.ScreenUpdating = True MsgBox sMsg, vbInformation, "www.excel-vba.ru" End Sub '--------------------------------------------------------------------------------------- ' File : mDownloadFileFromURL ' Purpose: код позволяет скачивать файлы из интернета по указанной ссылке ' https://www.excel-vba.ru/chto-umeet-excel/kak-skachat-fajl-iz-interneta-po-ssylke/ '--------------------------------------------------------------------------------------- Function CallDownload(sFileURL As String, sFileName As String) As Workbook 'переменная для хранения пути к папке Dim sFilePath As String, ToPathName As String Dim h sFilePath = Environ("temp") If Right(sFilePath, 1) <> "\" Then sFilePath = sFilePath & "\" ToPathName = sFilePath & sFileName 'проверяем есть ли файл с таким же именем в выбранной папке If Dir(ToPathName, 16) <> "" Then On Error Resume Next Kill ToPathName DoEvents On Error GoTo 0 End If 'если не возникло ошибок при удалении файла - скачиваем его по ссылке ' если ошибка была - значит такой файл уже открыт ' и в дальнейшем все равно получим ошибку If Err.Number = 0 Then 'вызов функции API для непосредственно скачивания h = (URLDownloadToFile(0, sFileURL, ToPathName, 0, 0) = 0) 'если h = False - файл не удалось скачать, показываем инф.окно If h = False Then MsgBox "Невозможно скачать файл." & vbNewLine & _ "Возможно, у Вас нет прав на создание файлов в папке '" & sFilePath & "'.", _ vbInformation, "www.excel-vba.ru" Set CallDownload = Nothing Exit Function Else 'файл успешно скачан If IsBookOpen(sFileName) Then MsgBox "Файл с именем '" & sFileName & "' уже открыт. Закройте открытый файл и повторите попытку.", vbCritical, "www.excel-vba.ru" Else Set CallDownload = Application.Workbooks.Open(ToPathName) End If End If Else Set CallDownload = Nothing End If End Function 'функция заполнения листа "ProdCalend" датами из производственного календаря ' предварительно функция разбивает даты на отдельные ' т.к. изначально они записаны в виде перечня дней для каждого месяца Function FillProdCalend(wbCSV As Workbook) Dim acsv, ares() Dim dic As Object Dim llastr&, lr&, lc&, lcnt& Dim ly&, lm&, ld& Dim asp, sd$, s$, x Dim dt As Date With wbCSV.Worksheets(1) llastr = .Cells(.Rows.Count, 1).End(xlUp).Row acsv = .Cells(1, 1).Resize(llastr, 13).Value End With With ThisWorkbook.Sheets("ProdCalend") 'очищаем лист от старых данных .Columns(1).Cells.Clear 'здесь будем хранить список уникальных дат Set dic = CreateObject("scripting.dictionary") dic.comparemode = 1 'просматриваем каждую строку файла(год), начиная со 2-й For lr = 2 To UBound(acsv, 1) If IsNumeric(acsv(lr, 1)) Then ly = Val(Trim(acsv(lr, 1))) 'просматриваем каждый столбец файла(месяц), начиная со 2-го For lc = 2 To UBound(acsv, 2) lm = lc - 1 s = acsv(lr, lc) s = Trim(s) 'убираем символы + 'которыми обозначаются перенесенные праздничные дни s = Replace(s, "+", "") If Len(s) Then 'разбиваем единую строку вида 1,2,3,4,6*,7,9,10,16,17,23,24,30,31 'на отдельные дни asp = Split(s, ",") 'перебор каждого дня и создание из него даты 'с запоминанием в словарь дат dic For Each x In asp s = Trim(x) 'не учитываем даты со знаком * - это сокращенные предпраздничные дни If InStr(1, s, "*", 1) = 0 Then If Len(s) Then ld = Val(s) dt = DateSerial(ly, lm, ld) If Not dic.exists(dt) Then dic.Add dt, 0& End If End If End If Next End If Next End If Next 'даты есть - записываем на лист ' можно было поступить проще ' .Cells(2, 1).Resize(dic.Count).Value = Application.Transpose(dic.Keys) ' но этот метод опасен тем, что порой может выгрузить не все данные ' хотя в данном конкретном случае это очень маловероятно, т.к. ограничения касаются ' кол-ва строк в 65536 и текста в каждой строке до 255 символов If dic.Count > 0 Then ReDim ares(1 To dic.Count, 1 To 1) lr = 0 For Each x In dic.keys lr = lr + 1 ares(lr, 1) = x Next .Cells(1, 1).Value = "Праздники и выходные" .Cells(2, 1).Resize(dic.Count).Value = ares End If End With End Function 'Функция проверки - открыта ли книга с заданным именем 'подробнее: ' https://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/ Function IsBookOpen(wbName As String) As Boolean Dim wbBook As Workbook For Each wbBook In Workbooks If Windows(wbBook.Name).Visible Then If wbBook.Name = wbName Then IsBookOpen = True: Exit For End If Next wbBook End Function |
Чтобы использовать код необходимо создать файл Excel, в этом файле создать лист с именем "
Product Calendar_VBA.xlsm (76,8 КиБ, 786 скачиваний)
Прежде чем читать далее и пробовать применить, необходимо знать азы работы в Power Query(Power Query - что такое и почему её необходимо использовать в работе?), уметь создавать и редактировать запросы и вызвать расширенный редактор: переходим в нужный запрос -Главная -Расширенный редактор:
В случае с Power Qwery все с одной стороны проще, а с другой есть свои нюансы. Взять хотя бы попытку получить напрямую текст страницы
Поэтому я использовал менее очевидный, но куда более удобный в данном случае вариант -
а дальше по сути идет тоже самое, что делалось кодом VBA: ищем в этом тексте ссылку, выдергиваем только ссылку для скачивания файла календаря, подключаемся к этой ссылке для получения конечного CSV и делаем преобразования. Только это выглядит куда проще и заметно короче, чем тоже самое на VBA :) Сам код из расширенного редактора:
let //получаем исходный текст страницы в виде разбитого на строки текста Source = Table.FromColumns({Lines.FromBinary(Web.Contents("https://data.gov.ru/opendata/7708660670-proizvcalendar"))}), //отбираем из строк ту, которая содержит внутри текст "Гиперссылка (URL) на набор" и ".csv" и превращаем все это в строку // т.к. изначально Table.SelectRows возвращает набор в виде таблицы CsvURLText = Table.SelectRows(Source, each Text.Contains([Column1], "Гиперссылка (URL) на набор") and Text.Contains([Column1], ".csv")){0}[Column1], //ищем начало гиперссылки url_start_pos = Text.PositionOf(CsvURLText,"http"), //ищем конец гиперссылки url_end_pos = Text.PositionOf(CsvURLText,".csv"), //формируем гиперссылку из CsvURLText url = Text.Middle(CsvURLText,url_start_pos,url_end_pos-url_start_pos+4), //скачиваем файл CSV по сформированной гиперссылке и открываем его //в заголовках будут имена месяцев csvfile = Table.PromoteHeaders(Csv.Document(Web.Contents(url),[Delimiter=",", Columns=18, Encoding=65001, QuoteStyle=QuoteStyle.None]), [PromoteAllScalars=true]), //сворачиваем столбцы с датами в два столбца: название месяца("Атрибут") и перечень дат("Значение") #"Несвернутые столбцы" = Table.UnpivotOtherColumns(csvfile, {"Год/Месяц", "Всего рабочих дней", "Всего праздничных и выходных дней", "Количество рабочих часов при 40-часовой рабочей неделе", "Количество рабочих часов при 36-часовой рабочей неделе", "Количество рабочих часов при 24-часовой рабочей неделе"}, "Атрибут", "Значение"), //убираем символы +, которыми обозначаются перенесенные праздничные дни #"Замененное значение1" = Table.ReplaceValue(#"Несвернутые столбцы","+","",Replacer.ReplaceText,{"Значение"}), //разбиваем столбец с днями на отдельные столбцы #"Разделить столбец по разделителю" = Table.SplitColumn(#"Замененное значение1", "Значение", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), {"Значение.1", "Значение.2", "Значение.3", "Значение.4", "Значение.5", "Значение.6", "Значение.7", "Значение.8", "Значение.9", "Значение.10", "Значение.11", "Значение.12", "Значение.13", "Значение.14", "Значение.15", "Значение.16"}), //сворачиваем все столбцы с днями в два: "Атрибут.1"(нам не нужен) и день("Значение") #"Другие столбцы с отмененным свертыванием" = Table.UnpivotOtherColumns(#"Разделить столбец по разделителю", {"Год/Месяц", "Всего рабочих дней", "Всего праздничных и выходных дней", "Количество рабочих часов при 40-часовой рабочей неделе", "Количество рабочих часов при 36-часовой рабочей неделе", "Количество рабочих часов при 24-часовой рабочей неделе", "Атрибут"}, "Атрибут.1", "Значение"), //удаляем все строки с сокращенными днями #"Строки с примененным фильтром" = Table.SelectRows(#"Другие столбцы с отмененным свертыванием", each not Text.Contains([Значение], "*")), //в отдельном столбце формируем из столбцов с годом, месяцем и днем дату #"Добавлен пользовательский объект" = Table.AddColumn(#"Строки с примененным фильтром", "Пользовательский", each Date.FromText([Значение] & " " & [Атрибут] & " " & [#"Год/Месяц"],"Ru-ru")), //переименовываем столбец #"Переименованные столбцы" = Table.RenameColumns(#"Добавлен пользовательский объект",{{"Пользовательский", "Дата"}}), //удаляем лишние столбцы(по сути все, кроме столбца дата) #"Другие удаленные столбцы" = Table.SelectColumns(#"Переименованные столбцы",{"Дата"}), //преобразуем тип Any(Любой) в тип Дата #"Измененный тип" = Table.TransformColumnTypes(#"Другие удаленные столбцы",{{"Дата", type date}}) in #"Измененный тип" |
Так же не стал расписывать со скринами по шагам все преобразования, т.к. каждый желающий может скачать файл(приложен ниже) с запросом PQ и просмотреть по шагам все действия:
Но если вдруг это надо будет - пишите в комментариях, постараюсь описать процесс наглядно(в будущем подготовлю видеоурок на данную тему).
Product Calendar_PQ.xlsx (59,9 КиБ, 789 скачиваний)
К сожалению, на data.gov.ru неточные данные, которые они не обновляли с 2019 года. Например, 5.11.2021 в данной таблице не выделен как праздничный. Лучше бы парсить суперджоб или консультант