Импортирование данных в эксель из интернета

[doober]

Задача трудоемкая.
У меня на листе Excel есть волшебная кнопка.
Кидаешь в нее монету и кнопка быстро пробежалась по сайту и собрала необходимые данные.по другому работать не хочет

[Zeon25]

Какого достоинства монетка, за хорошую кнопку которая бегает и делает все сама и монетки не жалко

[VIK83]

Здравствуйте! У меня похожая ситуация. Увлекся игрой http://elem.mobi/. Есть 1 проблемка .Если возможно, помогите в решении. У каждого игрока есть сила колоды. http://elem.mobi/user/94532/. Есть желание по Ид номеру игрока, который введен в столбце А получить силу колоды.

[VIK83]

shDATA.Range("B" & i) = Split(Result, "Сила колоды")

как прописать, кто бы брал нужною строку. При таком написании всю страницу заносит в ячейку.

[Hugo121]

shDATA.Range("B" & i) = Split(Result, "Сила колоды")(нужный номер)

[doober]

Можно и так.

Function Сила_колоды(ByVal s) As String
Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Pattern = ">Сила колоды</span><img[^>]*>([0-9\s]+)</div>"

    bRes = RegExp.test(s)
    If bRes Then
        Set oMatches = RegExp.Execute(s)
          Сила_колоды = Replace(oMatches(0).SubMatches(0), " ", "")
        
     End If

End Function

[VIK83]

Попробовал 2 мя способами. Обработка проходит, а результата нет

[pvocrion]

Здравствуйте! Помогите!
Есть макрос:

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, "&mdash;", "_")
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

работает, импортирует только http://31.2dr.ru/registratu/4/staroo...nitsy_2/1010/1

как можно сделать чтобы на одном листе друг за другом импортировались еще
http://31.2dr.ru/registratu/4/staroo...nitsy_2/1079/1

http://31.2dr.ru/registratu/4/staroo...nitsy_2/1066/1

и тд ....