ReSQL.ru
     
powered by simpleCommunicator - 2.0.51     © 2025 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Импорт данных с нескольких URL с приведением их к нужному виду
12 сообщений из 12, страница 1 из 1
Импорт данных с нескольких URL с приведением их к нужному виду
    #39404056
pvocrion
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
pvocrion
Гость
Здравствуйте! Помогите!
Есть макрос:
Код: 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, 12:43
| Ответить | Цитировать | Написать  
Импорт данных с нескольких URL с приведением их к нужному виду
    #39404221
Фотография big-duke
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
big-duke
Участник
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, 15:20
| Ответить | Цитировать | Написать  
Импорт данных с нескольких URL с приведением их к нужному виду
    #39404505
pvocrion
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
pvocrion
Гость
big-duke,

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

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

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

покажите что у вас получилось.
...
Рейтинг: 0 / 0
15.02.2017, 09:05
| Ответить | Цитировать | Написать  
Импорт данных с нескольких URL с приведением их к нужному виду
    #39404788
pvocrion
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
pvocrion
Гость
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:37
| Ответить | Цитировать | Написать  
Импорт данных с нескольких URL с приведением их к нужному виду
    #39404810
Фотография big-duke
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
big-duke
Участник
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, 12:55
| Ответить | Цитировать | Написать  
Импорт данных с нескольких URL с приведением их к нужному виду
    #39404835
pvocrion
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
pvocrion
Гость
big-duke,

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

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



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

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

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

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


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