Забыли пароль?


Хитрости »
Основные понятия (24)
Сводные таблицы и анализ данных (10)
Графики и диаграммы (5)
Работа с VB проектом (12)
Power BI и Power Query (17)
Условное форматирование (5)
Списки и диапазоны (5)
Макросы(VBA процедуры) (66)
Разное (42)
Баги и глюки Excel (4)

Производственный календарь в Excel (VBA и Power Qwery)

В одном из заказов недавно столкнулся с проблемой получения праздничных дней согласно утвержденному производственному календарю. Да, я знаю, что в компаниях он может быть свой, отличный от опубликованного государством. И смысла как-то получать список праздничных дат с общедоступных порталов не было. Но вот именно сейчас потребовался именно общедоступный опубликованный календарь, чтобы можно было его автоматом скачать и применить. И оказалось, что это тоже не самая простая задача: многие календари в сети либо в формате PDF, либо в виде frame-ов по месяцам, либо вообще картинками. Только на одном сайте получилось найти файл для скачивания: https://data.gov.ru/opendata/7708660670-proizvcalendar. Но и там оказалась не сразу ссылка на готовый календарь, а описание набора, потом паспорт и уже только в паспорте набора можно найти ссылку на файл:
Ссылка на производственный календарь
эта ссылка нам и нужна. И тут две проблемы:

  1. Набор может меняться периодически. Например, сейчас там выложен календарь от 1999 до 2025 года. Но в следующем году праздники на 2021 год могут поменяться и ссылка на набор тоже скорее всего изменится. Поэтому статичную ссылку на набор(https://data.gov.ru/opendata/7708660670-proizvcalendar/data-20191112T1252-structure-20191112T1247.csv) мы применить не можем - её желательно определять автоматом.
  2. Сам файл CSV не в самом удобном формате. Там не перечень дать, а годы и месяцы в строках и столбцах, и для каждого месяца в одной ячейке перечень праздничных дат через запятую для этого месяца. При этом не всегда удачно открывается, если заранее не задать кодировку:
    Структура файла производственного календаря
    Поэтому без доп.преобразований тут никак не обойтись.

Для рабочего проекта я выбрал способ получения дат через VBA(для поддержки всех версий независимо от надстроек), но в связи с популярностью Power Qwery решил сделать решение и при помощи этой надстройки.

  • Производственный календарь с сайта https://data.gov.ru при помощи VBA
  • Производственный календарь с сайта https://data.gov.ru при помощи Power Qwery

  •  
    Производственный календарь с сайта https://data.gov.ru при помощи VBA
    Решение использует два основных инструмента внутри Visual Basic for Application:

  • библиотеку MSXML2.XMLHTTP - для подключения к сайту https://data.gov.ru, чтобы считать текст полученной страницы с перечислением набора данных и найти там ссылку на файл CSV
  • Функции API для скачивания файла CSV по найденной ссылке. Подробный разбор данной функции приведен в статье: Как скачать файл из интернета по ссылке
  • Я постарался в коде в некоторых местах прописать комментарии, т.к. прописывать их напрямую в статье не очень удобно - код не маленький и описывать каждый кусок проблематично и больше запутает, чем прояснит процесс, как мне кажется.

    '---------------------------------------------------------------------------------------
    ' Author : Дмитрий (The_Prist) Щербаков
    '          Профессиональная разработка приложений для MS Office любой сложности
    '          Проведение тренингов по MS Excel
    '          https://www.excel-vba.ru
    '          info@excel-vba.ru
    '          WebMoney - R298726502453; Яндекс.Деньги - 41001332272872
    ' Purpose: Загрузка праздничных дат из производственного календаря с сайта data.gov.ru
    '          '
    '---------------------------------------------------------------------------------------
    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
     
    'Функция проверки - открыта ли книга с заданным именем
    'подробнее:
    '        http://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, в этом файле создать лист с именем "ProdCalend". Далее переходим в редактор VBA(Alt+F11) -Insert -Module. Вставляем туда код выше полностью. Или скачать файл ниже - там уже все сделано удобно и красиво:
    Скачать файл с кодом:

      Product Calendar_VBA.xlsm (76,8 KiB, 129 скачиваний)


     
    Производственный календарь с сайта https://data.gov.ru при помощи Power Qwery

    Прежде чем читать далее и пробовать применить, необходимо знать азы работы в Power Query(Power Query - что такое и почему её необходимо использовать в работе?), уметь создавать и редактировать запросы и вызвать расширенный редактор: переходим в нужный запрос -Главная -Расширенный редактор:
    Расширенный редактор

    В случае с Power Qwery все с одной стороны проще, а с другой есть свои нюансы. Взять хотя бы попытку получить напрямую текст страницы https://data.gov.ru/opendata/7708660670-proizvcalendar: если попытаться подключиться через стандартный метод(Другие(Other) -Из интернета(from Web), то придется очень долго разворачивать элемент Document на составные части разметки HTML в поисках тегов DIV и A для определения строки с гиперссылкой. Что на мой взгляд не оптимально и уж совсем не гибко - любое изменение структуры страницы, даже малейшее может привести к ошибке.
    Поэтому я использовал менее очевидный, но куда более удобный в данном случае вариант - Lines.FromBinary(Web.Contents("https://data.gov.ru/opendata/7708660670-proizvcalendar")). Это самая важная строка в текущей задаче - она получает исходный текст страницы сайта в виде разбитого на строки текста, в котором потом можно будет просматривать и искать нужное нам
    Power Qwery FromBinary function
    а дальше по сути идет тоже самое, что делалось кодом 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 и просмотреть по шагам все действия:
    Шаги запроса Power Qwery
    Но если вдруг это надо будет - пишите в комментариях, постараюсь описать процесс наглядно(в будущем подготовлю видеоурок на данную тему).

    Скачать файл с запросом:

      Product Calendar_PQ.xlsx (59,9 KiB, 126 скачиваний)


    Статья помогла? Поделись ссылкой с друзьями!
      Плейлист   Видеоуроки

    Поиск по меткам

    Access apple watch Multex Power Query и Power BI VBA управление кодами Бесплатные надстройки Дата и время Записки Надстройки Печать Политика Конфиденциальности Почта Программы Работа с приложениями Разработка приложений Тренинги и вебинары Финансовые Форматирование Функции Excel акции MulTEx ссылки
    Поделитесь своим мнением

    Комментарии, не имеющие отношения к комментируемой статье, могут быть удалены без уведомления и объяснения причин. Если есть вопрос по личной проблеме - добро пожаловать на Форум


    Для оформления сообщений Вы можете использовать следующие тэги:
    <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

    Тренинги

    Заказать
    Юридическая информация

    Использование материалов сайта

    Политика Конфиденциальности

    ИП Щербаков Дмитрий Валентинович
    ОГРНИП: 318502700083307
    ИНН: 504013350772

    Наши партнеры

    Перейти
    Перейти

    Счетчики

    Рейтинг@Mail.ru Яндекс.Метрика
    © 2020 Excel для всех   Войти