Гость
Войти | Профиль | Очистить
Действия ...
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Импорт данных с нескольких URL с приведением их к нужному виду / 12 сообщений из 12, страница 1 из 1
14.02.2017, 12:43
    #39404056
pvocrion
pvocrion
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
Здравствуйте! Помогите!
Есть макрос:
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
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




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

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

http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1066/1

и тд .... ?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
14.02.2017, 15:20
    #39404221
big-duke
big-duke
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
pvocrion,

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
Public Function Расписание (byval Url as string)
...  ' Код вашей процедуры
End Function

Public Sub FetchUrlData
call Расписание ("http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1079/1")
call Расписание ("http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1066/1")


End Sub
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
14.02.2017, 23:37
    #39404505
pvocrion
pvocrion
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
big-duke,

Не помогло, процедура проходит, но импорта нет...

Или может я что не так сделал?

Как это должно выглядеть в макросе?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 09:05
    #39404583
big-duke
big-duke
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
pvocrion,

покажите что у вас получилось.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 12:37
    #39404788
pvocrion
pvocrion
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
big-duke,
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
Public Function Расписание(ByVal Url As String)
    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 Function
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

Public Sub FetchUrlData()
Call Расписание("http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1079/1")
Call Расписание("http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1066/1")


End Sub



Что я сделал не так?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 12:55
    #39404810
big-duke
big-duke
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
pvocrion,

Код: vbnet
1.
2.
 Set Sh = ActiveSheet
  Sh.UsedRange.Clear



У вас каждая загрузка должна идти на отдельный лист или на один ?


Код: vbnet
1.
     Url = "http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1010/1"


У вас в коде жестко захардкоден Url.
Эту строку надо удалить, потому что Url это параметр.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 13:08
    #39404835
pvocrion
pvocrion
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
big-duke,

нужно чтобы Url страницы выводились на один лист, друг за другом
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 15:32
    #39405028
pvocrion
pvocrion
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
big-duke,

Получилось импортировать данные по нескольким ссылкам, но импорт происходит до 43 строки в листе.
всё, что не вместилось начинает перезаписываться на уже заполненные строки начиная с А4

Как сделать чтобы импорт продолжался дальше вниз листа без ограничения?

авторPublic Function Расписание(ByVal Url As String)
Set doc = CreateObject("htmlfile")
doc.Open '
Dim sl As String
Dim Sh As Worksheet
Set Sh = ActiveSheet


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

Public Sub FetchUrlData()
Call Расписание(" http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1010/1")
Call Расписание(" http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1066/1")
Call Расписание(" http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1023/1")
Call Расписание(" http://31.2dr.ru/registratu/4/starooskolskiy_gorodskoy_okrug/poliklinika_gorodskoy_bolnitsy_2/1030/1")


End Sub
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 16:34
    #39405098
big-duke
big-duke
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
pvocrion,

Код: vbnet
1.
Sh.Range("A4").Resize(Count2, Count1) = rez



У вас всегда результать выводится в одно и тоже место.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 16:59
    #39405133
pvocrion
pvocrion
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
big-duke,

Как сделать, что бы результат 2 ссылки выводился после окончания 1 ссылки, 3 после 2 и тд...?
или это не возможно?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 17:07
    #39405143
big-duke
big-duke
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
pvocrion,

Вы можете определить ячейку, в которой заканчивается вывод ссылки ?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
15.02.2017, 17:40
    #39405174
pvocrion
pvocrion
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Импорт данных с нескольких URL с приведением их к нужному виду
big-duke,

Определить количество строк, не возможно, это величина переменная
Как можно сделать чтобы по окончанию одной импортировалась следующая без превязки к конкретной ячейке?
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Импорт данных с нескольких URL с приведением их к нужному виду / 12 сообщений из 12, страница 1 из 1
Целевая тема:
Создать новую тему:
Автор:
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение
созд. / загр.: 456ms
Закрыть
start [/forum/topic.php?fid=60&mobile=1&tid=2155328]:
 0ms
get settings:
 9ms
get forum list:
 13ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 25ms
get topic data:
 11ms
get forum data:
 2ms
get page messages:
 88ms
get tp. blocked users:
 1ms
others: 301ms
total:  456ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]