Парсинг: выгрузить все выходные дни в году

Опубликовано автор kos20 
Sub ПолучитьРабДаты1(Y As Integer, RowStart As Integer, ColumnStart As Integer)
    Set doc = CreateObject("htmlfile")
    doc.Open    '
    Dim sl As String, Url As String
    Dim Sh  As Worksheet
    Set Sh = ActiveSheet
 
 Application.DisplayAlerts = False
 
    Sh.Range("2:3").Clear
 
 
 yar = Range("F1").Value
 
     Url = "http://www.consultant.ru/law/ref/calendar/proizvodstvennye/" & Y
'     Url = "http://www.consultant.ru/law/ref/calendar/proizvodstvennye/" & yar & "/"
 
 
    sl = ""
    ss = GetHTTPResponse(Url)
 
    doc.write ss
 
    week_name = "Врач;Имя отчество;Специальность;Участок;Кабинет;" 'строковая константа (добавить потом месяца)
 
 
    Do While doc.readyState = "loading"
        DoEvents
    Loop
 
cnt = 5
cnt1 = 0
Dim arr As Integer
Dim Cats As Collection 'объявляем коллекцию
Set Cats = New Collection 'создаем коллекцию
 
 
For Each td In doc.getElementsByTagName("td")
    If td.className = "month-block" Then
 
        For Each th In td.getElementsByTagName("th")
            If th.className = "month" Then
                    Debug.Print th.innertext
 
                    For Each td0 In td.getElementsByTagName("td")
                        If td0.className = "holiday weekend" Then
                              Debug.Print td0.innertext
                              Cats.Add CDate(td0.innertext & "." & th.innertext & "." & 2017)
                        End If
                    Next
 
            End If
 
        Next
 
 
    End If
Next
 
'Range("A10").Resize(, 12) = Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
'                            Debug.Print CDate(td.innertext & "." & tr.innertext & "." & 2017)
'                            Cats.Add CDate(td.innertext & "." & tr.innertext & "." & 2017)
 i = 0
 For Each c In Cats
 i = i + 1
 Cells(i + RowStart, ColumnStart) = c
 Next c
 
 
 
End Sub
 
Function GetHTTPResponse(ByVal sURL As String)
    Dim RRz As String
    On Error Resume Next
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sURL, False
        .setRequestHeader "If-Modified-Since", "Thu, 1 Jan 1970 00:00:00 UTC"
        .send
        GetHTTPResponse = .responseText
    End With
 
    Set oXMLHTTP = Nothing
 
End Function