Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для получения текста по web-ссылке
 
#1
18.01.2022 17:01:30
Уважаемые форумчане, требуется помощь в небольшом макросе.

Поставщик дает аннотацию к товару, но оформляет ее в виде web-ссылки в xls-файле. Т.е., чтобы прочитать аннотацию, надо кликнуть по ссылке, открывается браузер и можно читать. Соответственно, чтобы добавить эту информацию в свой прайс, ее надо скопировать и вставить. НО у поставщика больше 10000 товаров. Руками как-то больно. Сам не  могу придумать, как автоматизировать этот процесс.
Файл с примером прикладывается. В колонке А ссылки от поставщика, надо, чтобы после отработки макроса, в колонке В появился текст, который храниться по сслыке.
А2 = ссылка, В2 = текст, полученный по ссылке.
Заранее все большой спасибо!
 
 
 
#2
18.01.2022 17:41:24
Ну если совсем по простому, то так можно:
Код
Sub test()
    Dim http As Object: Set http = CreateObject("MSXML2.XMLHTTP")
    
    Dim r As Long
    For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        http.Open "GET", Cells(r, "A"), False
        http.Send
        Cells(r, "B") = http.responsetext
    Next r
    MsgBox "Done"
End Sub
 
 
 
#3
27.01.2022 14:36:44
webley,
Добрый день!
Вы мне очень помогли с макросом по этой теме. На небольших списках все хорошо.
Но на полном файле, где больше 10000 ссылок, макрос работает примерно 15 минут. Кроме того, текст в ячейке получается с включенным переносом. Как только хочу выделить столбец и выключить перенос, Excel опять "зависает" примерно на 15 минут. Можно это как-то исправить? Заранее большое спасибо!
 
 
 
#4
27.01.2022 17:28:38
Добрый день! Насколько я понимаю - долгая работа определяется как раз большим количеством ссылок. А вот по второй части (перенос строк) - попробуйте заменить строку
Код
Cells(r, "B") = http.responsetext
на
Код
Cells(r, "B") = Replace(http.responsetext, Chr(10), " ")
Должно помочь
 
 
 
#5
27.01.2022 17:35:52
webley
С переносом строк теперь все в порядке, спасибо!
А по времени  понятно — остается только ждать ,  :)  
 
 
 
#6
10.01.2023 13:24:07
webley,
Вот новый файл с примером, где есть пустые ячейки в колонке со ссылками
 
 
 
#7
10.01.2023 15:51:37
karlson7, надо добавить проверку на то, что в ячейке первого столбца действительно содержится URL:
Код
    For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        If Cells(r, "A") Like "http*" Then
            http.Open "GET", Cells(r, "A"), False
            http.Send
            Cells(r, "B") = Replace(http.responsetext, Chr(10), " ")
        End If
    Next r
 
 
 
#8
10.01.2023 15:57:30
webley,
спасибо большое! Все работает
 
 
 
#9
10.01.2023 16:24:00
Попробуйте отключить обновление экрана
Код
Application.ScreenUpdating = 0

Можно сначала все собрать в массив, а потом все скопом выгрузить. Что-то типа такого (проверить не могу, у меня доступ запрещен по ссылкам)
Код
Sub test()
    Dim http As Object: Set http = CreateObject("MSXML2.XMLHTTP")
    Application.ScreenUpdating = 0
    nr_ = Cells(Rows.Count, "A").End(xlUp).Row - 1
    ar = Cells(2, 1).Resize(nr_, 2).Value
    For i = 1 To UBound(ar)
        If Left(ar(i, 1), 4) = "http" Then
            http.Open "GET", ar(i, 1), False
            http.Send
            ar(i, 2) = Replace(http.responsetext, Chr(10), " ")
        End If
    Next i
    Cells(2, 1).Resize(nr_, 2).Value = ar
    Application.ScreenUpdating = 1
    MsgBox "Done"
End Sub
Скажи мне, кудесник, любимец ба’гов...
 
 
 
#10
10.01.2023 17:29:34
На мой взгляд, существенного прогресса можно добиться, если подготовить задание (конфигурацию) для программы Curl и выгрузить аннотации в параллельном режиме (опция Curl -Z).
Альтернативный подход демонстрировал Игорь здесь.
Владимир
 
 
 
#11
10.01.2023 17:42:24
_Boroda_,
sokol92,

спасибо за информацию, обновление экрана добавлю и по Curl почитаю.
Спасибо!
 
 
 
Страницы: 1
Наверх