Получить данные с сайта

Опубликовано автор kos20 
Sub Расписание()
    Set doc = CreateObject("htmlfile")
    doc.Open    '
    Dim sl As String, Url As String
     Dim Sh  As Worksheet
    Set Sh = ActiveSheet
 
 
    Sh.UsedRange.Clear
 
 
     Url = "http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1010/1"
 
 
 
 
    sl = ""
    ss = GetHTTPResponse(Url)
 
 
    ss = Replace(ss, "</sup><span", "</sup> - <span")
 
    ss = Replace(ss, "<sup>", "<sup>:")
    ss = Replace(ss, "—", "_")
    ss = Split(Split(ss, "<div id=""wrapper"">")(1), "<!-- #footer -->")(0)
 
    doc.write ss
 
    week_name = "Врач;Имя отчество;Специальность;Участок;Кабинет;"
 
 
    Do While doc.readyState = "loading"
 
        DoEvents
    Loop
    For Each span In doc.getElementsByTagName("span")
        If span.className = "week_name" Then week_name = week_name & 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