Извлечение HTML-кода с веб-сайтов путем просмотра списка URL-адресов.

Question

Я использую Excel VBA для запуска вкладки браузера IE на основе URL-адреса в каждой из строк в столбце D. Затем соответствующий HTML-код извлекается на основе предварительно определенных классов и заполняется в столбцах A - C.

Уверен, я пропустил шаг. Процесс останавливается на D2 и не переходит к извлечению HTML из следующих URL-адресов (в ячейках D3, D4 и т. Д.).

Заранее спасибо за любые предложения!

Sub useClassnames()
Dim element As IHTMLElement
Dim elements As IHTMLElementCollection
Dim IE As InternetExplorer
Dim html As HTMLDocument
Dim shellWins As New ShellWindows
Dim IE_TabURL As String
Dim intRowPosition As Integer

Set IE = New InternetExplorer
IE.Visible = False

intRowPosition = 2

Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True

IE.navigate Sheet1.Range("D" & intRowPosition)

While IE.Busy
    DoEvents
Wend

intRowPosition = intRowPosition + 1

While Sheet1.Range("D" & intRowPosition) <> vbNullString
    IE.navigate Sheet1.Range("D" & intRowPosition), CLng(2048)

    While IE.Busy
        DoEvents
    Wend

    intRowPosition = intRowPosition + 1

Wend

Do While IE.readyState <> READYSTATE_COMPLETE
Application.StatusBar = "Loading Web page…"
DoEvents
Loop

Set html = IE.document
Set elements = html.getElementsByClassName("container-bs")

Dim count As Long
Dim erow As Long
count = 0
For Each element In elements
If element.className = "container-bs" Then
erow = Sheet1.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
Cells(erow, 1) = html.getElementsByClassName("pull-left")(count + 1).innerHTML
Cells(erow, 2) = html.getElementsByClassName("description")(count).innerHTML
Cells(erow, 3) = html.getElementsByClassName("related-articles")(count).innerHTML
count = count + 1
End If
Next element

Range("A2:C2000").Select
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").ColumnWidth = 36
End Sub

Answer 1

Ваши строки

Set html = IE.document
Set elements = html.getElementsByClassName("container-bs")

и т. Д. Происходят после цикла While. Это должно быть внутри.

---

Ваше If заявление:

If element.className = "container-bs"

должен быть избыточным, так как вы уже перебираете коллекцию этого имени класса; поэтому я удалил это.

---

Вы не отрабатываете element в цикле, поэтому, по сути, вы используете его для управления вашей переменной увеличенного счетчика. Это говорит о том, что вы можете использовать лучшую стратегию кодирования для извлечения интересующих элементов.

---

Всегда указывайте родительский лист и не полагайтесь на неявные ссылки на Activesheet - это подвержено ошибкам.

---

Я бы ожидал, что структура будет выглядеть примерно следующим образом (я не могу учесть рефакторинг для удаления element)

---

Option Explicit
Public Sub UseClassnames()
    Dim element As IHTMLElement, elements As IHTMLElementCollection, ie As InternetExplorer
    Dim html As HTMLDocument, intRowPosition As Long

    intRowPosition = 2
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = True

    While Sheet1.Range("D" & intRowPosition) <> vbNullString

        If intRowPosition = 2 Then
            ie.navigate Sheet1.Range("D" & intRowPosition)
        Else
            ie.navigate Sheet1.Range("D" & intRowPosition), CLng(2048)
        End If

        While ie.Busy Or ie.readyState < 4: DoEvents: Wend

        Set html = ie.document
        Set elements = html.getElementsByClassName("container-bs")

        Dim count As Long, erow As Long

        count = 0

        For Each element In elements
            erow = Sheet1.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).Row
            With Sheet1
                .Cells(erow, 1) = html.getElementsByClassName("pull-left")(count + 1).innerHTML
                .Cells(erow, 2) = html.getElementsByClassName("description")(count).innerHTML
                .Cells(erow, 3) = html.getElementsByClassName("related-articles")(count).innerHTML
            End With
            count = count + 1
        Next element

        intRowPosition = intRowPosition + 1
    Wend
    With Sheet1
        .Range("A2:C2000").Select
        .Columns("A:A").EntireColumn.AutoFit
        .Columns("B:B").ColumnWidth = 36
    End With
End Sub