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
| Sub ЗагрузкаСпискаНомеровExcel()
Dim CStart As Range, BaseStart As Range, Firm$, Mail$, Face$, Ex$, NotEx$, Success As Boolean
Dim yBase&
Dim ra As Range, rak As Range, ran As Range, raq As Range, raw As Range, rae As Range, rar As Range, rat As Range, oCell As Range, n As Long: On Error Resume Next
Dim c As Range, ray As Range, rau As Range, rai As Range, rao As Range, rap As Range, raa As Range, rng As Range
Dim i As Long
With ThisWorkbook.Sheets("Лист3")
'Нижеследующее присвоение ссылки на объект в данном макросе не используется.
Set CStart = .[A1] 'реестровые номера заказа с листа № 3 (ячейка А5)
For i = 1 To .UsedRange.End(xlDown).Row + 10
If Val(Right(.Cells(i, 1), 19)) > 1 Then
' формируем ссылку
' Сайт и поисковый запрос к сайту.
'Синтаксис построения запроса определяется поисковой машиной сайта
URL$ = "http://www.bus.gov.ru/public/print-form/show.html?pfid=" & Right(ThisWorkbook.Sheets("Лист3").Cells(i, 1), 19)
'- после равно должно вставляться поле с реестровым номером заказа (А1) и так по порядку, потом надо чтобы копировался текст ссылки на заказ
Do
Set rng = GetQueryRange(URL$, "1")
' перебирая ячейки таблицы-результата, выводим список тем в окно Immediate
Set rng = rng.Columns(2).Find("23000000000 Краснодарский край", , xlValues, xlWhole, xlPart) = True 'истина, при данном найденом значении цикл будет работать далее
'rng = "23000000000 Краснодарский край" = True
If Not rng Is Nothing Then Set rng = GetQueryRange(URL$, "1") + i 'если значение "23000000000 Краснодарский край" не обнаруженно, то цикл повторяет снова запрос уже со следующей строки столбца А
Set ra = GetQueryRange(URL$, "1")
If Not ra Is Nothing Then
Set c = ra.Columns(1).Find("ИНН*", , xlValues, xlWhole)
If Not (c Is Nothing) Then Debug.Print c.Offset(, 1).Value
Worksheets("Лист3").Cells(1 + i, 2) = c & c.Offset(, 1)
End If
Loop Until Not rng Is Nothing
End If
Next i
End With
End Sub
Function GetQueryRange(ByVal SearchLink$, Optional ByVal Tables$) As Range
On Error Resume Next: Err.Clear
Dim tmpSheet As Worksheet, tmpSh As Worksheet
With ThisWorkbook
' Перебираем все листы книги
For Each tmpSh In .Worksheets
If tmpSh.Name = "tmpWQ1" Then
'Если существует лист и именем "tmpWQ1",
' то присваиваем ссылку на него переменной tmpSheet
Set tmpSheet = tmpSh
Exit For
End If
Next tmpSh
'Если лист и именем "tmpWQ1" не существует
If tmpSheet Is Nothing Then
Application.ScreenUpdating = False
'то добавляем в книгу новый лист и присваиваем ссылку на него переменной tmpSheet
Set tmpSheet = .Worksheets.Add(After:=.Sheets(Sheets.Count))
' Переименовываем вновьджобавленный лист на "tmpWQ1"
tmpSheet.Name = "tmpWQ1"
' скрываем этот лист
tmpSheet.Visible = xlSheetVeryHidden
End If
End With
If tmpSheet Is Nothing Then
msg$ = "Не удалось добавить скрытый лист «tmpWQ1» в файл программы"
MsgBox msg, vbCritical, "Невозможно выполнить запрос к сайту": End
End If
' Работаем с временным листом
With tmpSheet
'.Activate ' выделяем его, если нужно его видеть при отладке ###
' Удаляем все ячейки с временного листа
.Cells.Delete
' Даем время на обработку событий системы.
DoEvents:
'Обнуляем ошибки программы для обработчика ошибок.
Err.Clear
' Работаем с методом Add таблицы запроса внешних данных QueryTables
With .QueryTables.Add("URL;" & SearchLink$, .Range("A1"))
If Len(Tables$) Then
' Тип Web-запроса
.WebSelectionType = xlSpecifiedTables
' Номер таблицы на сайте, зависит от структуры сайта.
' В нашем случае нужную тавблицу сайт не дает,
' и скорее всего просто выводит всю станицу с найденным
.WebTables = Tables$
Else
.WebSelectionType = xlEntirePage
End If
' Параметр обновления формул, рядом с QueryTables
' должны ли они пересчитываться при полчении новых данных
.FillAdjacentFormulas = False
' Повторение формата 5 первых строк QueryTables
.PreserveFormatting = True
'Не обновлять QueryTables при открытии файла
.RefreshOnFileOpen = False
' Даем время на обработку событий системы.
DoEvents
' Сохраняем форматирование строк сайта, включая гиперссылки.
.WebFormatting = xlWebFormattingAll
' Запрашиваем данные по запрсу QueryTables
' и ждем их получения.
.Refresh BackgroundQuery:=False
End With
End With
' Если не было сбоев, то присваиваем данной функции
' ссылку на заполненный диапазон временного лииста.
If Err = 0 Then Set GetQueryRange = tmpSheet.UsedRange
End Function |
(
