Поиск и импорт данных из интернета

[dobrohleb]

Всем добрый день, вечер или утро!!! Прошу Вашей помощи в решении следующей задачи:
необходимо реализовать средствами VBA поиск данных в интернете и затем дальнейший их импорт, например, в книгу Excel.

Создать нечто подобное через веб-запрос пробовал, но появились некоторые затруднения. Дело в том, что это необходимо для заполнения каталога фильмов. Т.е. у меня есть только название фильма и нужно в интернете (а именно на сайте кинопоиск.ру) осуществить поиск фильма по названию и импортировать обратно в книгу данные о нем (год, жанр, режиссеры и т.п).

Бо большому счету нужен только макрос, который бы помог реализовать данную задачу.

Помогите, пожалуйста, в решении данного вопроса.

Заранее Всем очень благодарен!!!

[EducatedFool]

Это будет весьма непросто сделать.

Одно дело - запустить поиск по некой фразе, потом щелкнуть по первой ссылке в результатах, и скопировать оттуда нужные значения.
(и то весьма сложный код получится)

А что делать, если по запросу фильмы не найдены? (или найдено 1163 фильма, как по запросу "любовь")
Тут всё намного сложнее.

Сомневаюсь, что кто-то бесплатно предложит вам готовое решение.

[dobrohleb]

Я с Вами согласен. Нюансов в данной задаче много.
Готов упростить задачу. Меня интересует именно та часть кода, которая отвечает за ввод данных в поле поиска фильма. С тем, что оно потом выдаст, я постараюсь справиться сам, будь то 1000 результатов или ни одного.

П.С. Названия фильмов будут строго соответствовать оригиналу, так что в принципе тут будет только два варианта: либо фильм есть, либо нет (что маловероятно, т.к. фильмы в базе не самые новые)

[EducatedFool]

от вас - пример исходной таблицы (со списком фильмов для поиска),
и пример того, что должно получиться после поиска по сайту.

Попробуем что-нибудь изобрести.

[motorway]

Я посмотрел - там разве на сайте поиск не сделан с помощью запроса в адресной строке? Тогда надо просто сделать функцию, которой передается название фильма, и она выдает HTML-код результата с сервера

[dobrohleb]

Вот файл с исходными данными: импорт.rar

[EducatedFool]

Я что-то не понял...

Вот, к примеру, на листе ФИЛЬМ у вас 9 записей.
Для каждого фильма создавать отдельный лист РЕЗУЛЬТАТ?

Я-то думал, что в ту же таблицу (на листе ФИЛЬМ) надо добавить несколько столбцов (справа от названия фильма) - таких, как:
год
страна
слоган
режиссер
сценарий
продюсер

[EducatedFool]

Сделал я вам всё-таки программу.

Проверяйте:



Процесс обработки отображается в строке состояния Excel.


Вот весь код:

Sub Запуск()
    Dim cell As Range, ra As Range
    Set ra = Range([A2], Range("A" & Rows.Count).End(xlUp))
    For Each cell In ra.Cells
        cell.Next.Resize(, 11).Value = GetFilmArray(cell): DoEvents
    Next cell
    Application.StatusBar = False
    ra.EntireRow.AutoFit
End Sub

Sub Очистка()
    Range([A2], Range("A" & Rows.Count).End(xlUp)).Offset(, 1).Resize(, 20).ClearContents
End Sub

Function GetFilmArray(ByVal Фильм As String)
    On Error Resume Next
    tmp.Range("a1:b20").ClearContents
    Фильм = Trim(Split(Фильм, "/")(0))
    Application.StatusBar = "Запрос для фильма """ & Фильм & """"
    ссылка = "URL;" & СтрокаЗапроса(Фильм)

    With tmp.QueryTables.Add(ссылка, tmp.Range("A1"))
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .WebSelectionType = xlSpecifiedTables
        .WebTables = "9"
        .Refresh BackgroundQuery:=False
        GetFilmArray = Application.Transpose(tmp.Range("b1:b11").Value)
        .Delete
    End With
End Function


Function RussianStringToURLEncode(ByVal txt As String) As String
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 256: t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
            Case 32: t = "+"
            Case Else: t = l
        End Select
        RussianStringToURLEncode = RussianStringToURLEncode & t
    Next
End Function

Function СтрокаЗапроса(ByVal ФразаДляПоиска As String) As String
    СтрокаЗапроса = "http://www.kinopoisk.ru/index.php?first=yes&kp_query=" & _
                    RussianStringToURLEncode(ФразаДляПоиска)
End Function

[dobrohleb]

СПАСИБО!!! Задачу решили великолепно!!! Очень Вам благодарен. Я просто в восторге! Всё работает так, как нужно!!!

[Flurt]

Добрый день!
А мне не поможете? Задача в следующем, наверное даже чуть проще имея ссылку на кинопоиск с фильмом выдернуть оттуда в таблицу exel английское название, год, рейтинг кинопоиска, рейтинг IMDB, режиссера.
Заранее благодарен