Парсинг (получить рабочие дни с консультатнта)

Опубликовано автор kos20 
Sub Расписание()
    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/2017/"
     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 = 0
cnt1 = 0
Dim arr As Integer
Dim Cats As Collection 'объявляем коллекцию
Set Cats = New Collection 'создаем коллекцию
 
    For Each tr In doc.getElementsByTagName("div")
cnt1 = cnt1 + 1
        If tr.className = "count-days" Then
                cnt = cnt + 1
                Count = 0
                For Each span In tr.getElementsByTagName("span") 'Данные выводятся по списку
                     Count = Count + 1
                     If Count = 2 Then
 
                        Select Case cnt
                            Case 2 To 4: Debug.Print span.innertext: Cats.Add span.innertext
                            Case 10 To 12: Debug.Print span.innertext: Cats.Add span.innertext
                            Case 18 To 20: Debug.Print span.innertext: Cats.Add span.innertext
                            Case 26 To 28: Debug.Print span.innertext: Cats.Add span.innertext
 
                        End Select
 
                     End If
 
                Next
 
'
'
'              If Count = 2 Then
'                 Debug.Print tr.innertext: Count = 0
'              End If
 
        End If
    Next
 
Range("A2").Resize(, 12) = Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
 i = 0
 For Each c In Cats
 i = i + 1
 Cells(3, i) = c
 Next c
 
'        CounDays = CounDays & tr.innertext & ";"
'========================================================
 
 
'    For Each span In doc.getElementsByTagName("span")
'        If span.className = "week_name" Then week_name = week_name & span.innertext & ";"
'            Debug.Print span.innertext
'            Next
'
'
'    For Each div In doc.getElementsByTagName("div")
'
'        If div.className = "week_name" Then week_name = week_name & div.innertext & ";"
'
'        If div.className = "list_choose_doc" Then
'
'            sl = sl & "||"
'
'
'            For Each dv In div.getElementsByTagName("div")
'                If dv.className = "div_table_week" Then
'                    Set div_table_week = dv.getElementsByTagName("table")(0)
'
'                    For c = 0 To div_table_week.Cells.Length - 1
'                        Set cel = div_table_week.Cells(c)
'                        sl = sl & cel.innertext & ";"
'
'                    Next
'
'                End If
'
'                If dv.className = "list_choose_time" Then
'                    Set div_table_week = dv.getElementsByTagName("table")(0)
'
'                    For c = 0 To div_table_week.Cells.Length - 1
'                        Set cel = div_table_week.Cells(c)
'                        sl = sl & cel.innertext & ";"
'                    Next
'
'                End If
'            Next
'
'        End If
' Next
'
'    Count1 = UBound(Split(week_name, ";")) + 2
'
'    sl = Replace(week_name & sl, vbCrLf, " ; ")
'    ZX = Split(sl, "||")
'    Count2 = UBound(ZX) + 1
'    ReDim rez(1 To Count2, 1 To Count1)
'    For n = 0 To Count2 - 1
'        ZZ = Split(ZX(n), ";")
'        For i = 0 To Count1 - 1
'            If i <= UBound(ZZ) Then
'                rez(n + 1, i + 1) = Trim(ZZ(i))
'            End If
'
'        Next
'    Next
'    Set doc = Nothing
'Sh.Range("A4").Resize(Count2, Count1) = rez
 
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