Получение данных с адреса веб-сайта на основе значений Excel

Question

У меня проблема с написанием макроса для Excel VBA, и я не смог найти точный ответ на то, что я ищу.

У меня следующий URL:

http://ratings.ambest.com/companyprofile.aspx?ambnum=2257

И у меня есть список идентификаторов в столбце A моего листа Excel, который мне нужно ввести в последнюю часть этого URL (изменив 2257 на, скажем, 73132 и 1996 в примере). Затем мне нужно получить кредитный рейтинг на полученной веб-странице, который будет следующим полем:

div id = "MainContent_FSRandICR_AffilCodeDiv"

Итак, мне нужен макрос that:

• Изменяет последний раздел URL-адреса на основе значений в столбце A рабочего листа.
• Извлекает данные из поля с тегом div id = "MainContent_FSRandICR_AffilCodeDiv"
• Разбирает их в одну таблицу Excel в столбце B, поэтому для каждого идентификатора у меня будет свой кредитный рейтинг.
• Повторяется до EOF

Мне удалось создать макрос на основе этого видео , но с ним много проблем, а именно:

• Я должен ввести каждый идентификатор вручную, тогда как я хочу, чтобы он автоматически считывал значения в данном столбце

• Он выбирает значение из тега "td", которое дает мне больше данных, чем я хочу (я не смог заставить его работать с div id).

  <code>Private Sub Worksheet_Change(ByVal Target As Range)
      If Target.Row = Range("Code").Row And _
      Target.Column = Range("Code").Column Then
      Dim IE As New InternetExplorer
      IE.Visible = True
      IE.navigate "<a href="http://ratings.ambest.com/companyprofile.aspx?ambnum=" rel="nofollow noreferrer">http://ratings.ambest.com/companyprofile.aspx?ambnum=</a>" & Range("Code").Value
      Do
          DoEvents
      Loop Until IE.readyState = READYSTATE_COMPLETE
      Dim Doc As HTMLDocument
      Set Doc = IE.document
      Dim sDD As String
      sDD = Trim(Doc.getElementsByTagName("td")(1).innerText)
      IE.Quit
      Dim aDD As Variant
      aDD = Split(sDD, ",")
      Range("AMBest").Value = aDD(0)
      End If
  End Sub

Большое спасибо заранее за вашу помощь!

ОБНОВЛЕНИЕ: Это мой текущий макрос с помощью YasserKhalil:

<code><pre><code>Sub Test()
Dim aDD, ie As New InternetExplorer, htmlDoc As HTMLDocument, sDD As String, r As Long

Application.ScreenUpdating = False
    For r = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        ie.Visible = False
        ie.navigate "http://ratings.ambest.com/companyprofile.aspx?ambnum=" & Cells(r, 1).Value
        Do: DoEvents: Loop Until ie.readyState = READYSTATE_COMPLETE
        Set htmlDoc = ie.document
        On Error GoTo Skipper
        sDD = Trim(htmlDoc.getElementsByTagName("td")(1).innerText)
        aDD = Split(sDD, ",")
        Cells(r, 2).Value = aDD(0)
Skipper:
    Next r
ie.Quit
Application.ScreenUpdating = True
End Sub

Это работает, но время от времени я получаю перенаправлено, чтобы ответить на код проверки, который, когда решено, позволяет мне ввести URL, первоначально установленный в макросе. Я хочу, чтобы макрос отображал IE, если он будет перенаправлен, чтобы я мог решить капчу. Затем можно возобновить макрос, как только он достигнет правильного URL. Это возможно?

Answer 1

Не проверено

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Target.Column = 1 Then
    Dim aDD, ie As New InternetExplorer, htmlDoc As HTMLDocument, sDD As String
    ie.Visible = False
    ie.navigate "http://ratings.ambest.com/companyprofile.aspx?ambnum=" & Target.Value
    Do: DoEvents: Loop Until ie.readyState = READYSTATE_COMPLETE
    Set htmlDoc = ie.document
    sDD = Trim(htmlDoc.getElementsByTagName("td")(1).innerText)
    ie.Quit
    aDD = Split(sDD, ",")
    Target.Offset(, 1).Value = aDD(0)
End If
End Sub

И с использованием петель

Sub Test()
Dim aDD, ie As New InternetExplorer, htmlDoc As HTMLDocument, sDD As String, r As Long

Application.ScreenUpdating = False
    For r = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        ie.Visible = False
        ie.navigate "http://ratings.ambest.com/companyprofile.aspx?ambnum=" & Cells(r, 1).Value
        Do: DoEvents: Loop Until ie.readyState = READYSTATE_COMPLETE
        Set htmlDoc = ie.document
        sDD = Trim(htmlDoc.getElementsByTagName("td")(1).innerText)
        ie.Quit
        aDD = Split(sDD, ",")
        Cells(r, 2).Value = aDD(0)
    Next r
Application.ScreenUpdating = True
End Sub