Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA - Получение веб-данных по списку URL
 
#1
26.09.2015 01:36:48
Здравствуйте. Необходимо следущее:
На первом листе книги в столбце А расположен список URL. Необходимо выполнить веб-запрос по этим адресам (запрос однотипный, извлекаются определённые таблицы, а вот URL разные, вручную займёт огромное количество времени), каждый раз записывая его результаты в новый лист книги.
В интернете находил решения, в которых давался некоторый однотипный адрес, вида ?id=xxxxx и xxxxx менялись, мне же нужно просто пройтись по адресам из списка. Почему каждый раз на новый лист? Потому что длина таблиц разная, возможно, возникнут проблемы если копировать в строку за предыдущей таблицей на одном листе.
Вот пример кода для единичного запроса (как я понял, чтобы осуществить моё, нужно всё в цикл, который закончится на последнем адресе из столбца A; в connection= отправлять строку из A(i-го), а в destination указывать каждый раз новый лист, перед этим его создав ):
Код
Sub GetNames()

    Application.Run "Êíèãà1!Ìàêðîñ2"
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://names.mongabay.com/most_common_surnames.htm", Destination:=Range( _
        "$A$1"))
        .CommandType = 0
        .Name = "most_common_surnames"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub
Изменено: FuncX - 26.09.2015 01:37:15
 
 
 
#2
26.09.2015 08:41:50
Так Вам нужен один запрос или все на одном листе?
1-й в $A$1
2-й например в $A$200 и т.д.
я правильно понял?
 
 
 
#3
26.09.2015 11:18:00
Цитата
Catboyun написал:
Так Вам нужен один запрос или все на одном листе?
1-й в $A$1
2-й например в $A$200 и т.д.
я правильно понял?
Извините за плохое объяснение. Нужно множество запросов, каждый запрос запрос берёт адрес из столбца A и помещает результат либо на другом листе (в одном, по порядку, результат за результатом, без перезаписи), либо каждый раз на новый лист (думаю, что на одном листе придётся возится). Накидал в пейнте схему, может поможет понять.
Изменено: FuncX - 26.09.2015 11:20:41
 
 
 
#4
26.09.2015 15:04:34
Могу предложить без веб-запроса на лист
 
 
 
#5
26.09.2015 16:38:35
Цитата
Doober написал:
Могу предложить без веб-запроса на лист
Спасибо за ваши старания. Внешне как раз то, что нужно, но к сожалению, дело в том, что та ссылка была дана для примера, веб-запрос должен быть относительно универсальным, чтобы указав номер таблицы можно было получить с нескольких разных сайтов, поддерживающих обработку веб-запросом, парсинг под каждый отдельный сайт нет смысла делать. Легче будет получить данные в более-менее табличном виде, потом уже удалить пустые строки и т.п.
Вот тут добавил псевдокод (помечен звёздочками) для случая когда на один лист все таблицы, чтобы объяснить ещё. Вроде бы так должно работать, но как сделать это в подробностях на самом языке, не знаю.
Код
Sub GetNames()
 
    Application.Run "Êíèãà1!Ìàêðîñ2"
    *пока  (не пустая ячейка в столбце А) делать:
    k=k+1
    i = НомерПоследнейЗанятойЯчейки в (ТекущаяКнига.Лист2.СтолбецА) + 1*
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;*ТекущаяКнига.Лист1.А[k]*", Destination:=*ТекущаяКнига.Лист2.А[i]*
        .CommandType = 0
        .Name = *ПолучитьИмяФайла(A[k])*//не знаю, нужно ли это вообще или достаточно полного url, который мы уже указали
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        *  .WebTables = "2"* //тут будет номер таблицы на странице вместо .WebSelectionType = xlAllTables

        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub
Изменено: FuncX - 26.09.2015 16:39:11
 
 
 
#6
26.09.2015 18:19:30
Цитата
FuncX написал: Вроде бы так должно работать...
если хотите именно через запросы (что дОльше, чем код, предложенный Doober) - то можно, как в коде от Doober, прогнать запросы циклом... см. модуль Листа1 (и комменты там)...  принцип такой...
P.S. ... и убрала пустые строки... Перевложила файл
(чуть что - подправите по ситуации проверку в первых 20 строках (на глаз), чтобы не искать далее - см. комменты по коду)
 
Изменено: JeyCi - 26.09.2015 19:37:04
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
 
 
#7
27.09.2015 01:12:47
Примерно додумался как сделать для случая с одним листом. Выдаёт ошибку в конце выполнения (1004), но данные добавляет (может что-то подправить надо). Сам решил постепенно делать парсер вместо этого, но вот код, может кому пригодится:
Код
Sub Макрос1()

    Dim CurRow As Long
    For Each link In Worksheets("Лист1").Range("A:A").Cells
     With Worksheets("Лист2")
        CurRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    End With
    With Worksheets("Лист2").QueryTables.Add(Connection:= _
        "URL;" & link.Value, Destination:=Worksheets("Лист2").Range("$A$" & CurRow _
        ))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        '.WebSelectionType = xlAllTables
        .WebFormatting = xlNone
        '.WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = False
        .WebSingleBlockTextImport = True
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
Next
End Sub
 
 
 
#8
27.09.2015 18:17:59
Цитата
FuncX написал: Сам решил постепенно делать парсер вместо этого
тогда ЗАЧЕМ было слать личное сообщение постороннему человеку? - до того, как подумали сами  ;) ...
p.s. - не приветствуется чужой ход мыслей в своём почтовом ящике... вопросы ветки лучше задавать по ветке...
p.p.s. там всё было откомментировано, но можно и одним модулем: (выполнять на активном листе со списком url)

в обычный модуль
Изменено: JeyCi - 27.09.2015 18:27:25
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
 
 
#9
28.09.2015 13:22:39
Подскажите пожалуйста как в етом макросе можно задать ожидания на полную загрузку веб страници? (примерно 2 - 3 секунды).
 
 
 
#10
28.09.2015 13:45:45
Приостановка на три секунды:
Код
Application.Wait Time:=Now + TimeValue("0:00:03")
 
 
 
#11
28.09.2015 14:04:21
Спасибо за ответ, не сочтите за наглость, а куда в самом макросе вставить указанную Вами строчку?
 
 
 
#12
28.09.2015 15:05:53
На какой строке у Вас происходит соединение? Вот после неё и добавьте )
 
 
 
#13
28.09.2015 19:06:14
К сожелению етот макрос не мой, а уважаемого "JeyCi" и я не знаю в каком месте происходит соединение и по етому прошу Вас помощи.
Изменено: alex15 - 28.09.2015 19:06:52
 
 
 
#14
28.09.2015 22:43:38
Не разбирался, но попробуйте перед удалением подключения.
 
 
 
#15
28.09.2015 22:55:53
JeyCi, я примерно сделал, посмотрел, что результат всё же не совсем удовлетворительный выходит (до этого, когда по-одному делал, добавлял вручную, казалось, что более-менее) и решил от такого метода отказаться. А от вас  ответа не ожидал бесплатного, поэтому сначала просто спросил, чтобы потом договориться.
Изменено: FuncX - 28.09.2015 22:56:38
 
 
 
Страницы: 1
Читают тему
Наверх