Выходные дни в excel vba

'---------------------------------------------------------------------------------------
' 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

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
    #"Измененный тип"