Webscraping в vba - структурировать рабочие данные и записывать в ячейку слева направо - PullRequest
Новая
       4

Webscraping в vba - структурировать рабочие данные и записывать в ячейку слева направо

1 голос
/ 19 апреля 2020

только что зарегистрировал аккаунт здесь, и да, я настоящий нуб - пожалуйста, будь мил со мной. Теперь о моей задаче: я строю веб-скребок в VBA и нашел код, который я немного изменил для своих нужд. Все работает отлично и на самом деле довольно гладко. Теперь я хотел бы, чтобы мой текст, который загружается в мой документ exel, был не длинным, а широким. Я подозреваю, что это связано с ".Offset (I, j)". Я немного поиграл с этим, но мне все удалось испортить. Вот мой код: us 1001 

Dim IE As InternetExplorer
Dim htmldoc As MSHTML.IHTMLDocument 'Document object
Dim eleColtr As MSHTML.IHTMLElementCollection 'Element collection for tr tags
Dim eleColtd As MSHTML.IHTMLElementCollection 'Element collection for td tags
Dim eleRow As MSHTML.IHTMLElement 'Row elements
Dim eleCol As MSHTML.IHTMLElement 'Column elements
Dim ieURL As String 'URL

'Open InternetExplorer
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
'Navigate to webpage
ieURL = "#"
IE.Navigate ieURL
'Wait
Do While IE.Busy Or IE.ReadyState <> 4
 DoEvents
Loop
Set htmldoc = IE.Document 'Document webpage
Set eleColtr = htmldoc.getElementsByTagName("tr") 'Find all tr tags
'This section populates Excel
I = 0 'start with first value in tr collection
For Each eleRow In eleColtr 'for each element in the tr collection
 Set eleColtd = htmldoc.getElementsByTagName("tr")(I).getElementsByTagName("td") 'get all the td elements in that specific tr
 j = 0 'start with the first value in the td collection
 For Each eleCol In eleColtd 'for each element in the td collection
 Sheets("Sheet1").Range("A1").Offset(I, j).Value = eleCol.innerText 'paste the inner text of the td element, and offset at the same time
 j = j + 1 'move to next element in td collection
 Next eleCol 'rinse and repeat
 I = I + 1 'move to next element in td collection
Next eleRow 'rinse and repeat

End Sub ```

1 Ответ

2 голосов
/ 19 апреля 2020

Вам не нужен браузер. Вы можете использовать быстрее XHR. Возьмите таблицу и l oop строки, а затем столбцы, заполняющие массив заданного размера (обязательно удалите строки, в которых находятся заголовки. Их можно идентифицировать как имеющие [colspan='2'] в их первом td). Затем перенесите массив и запишите на лист. 

Option Explicit

Public Sub TransposeTable()
    Dim xhr As MSXML2.XMLHTTP60, html As MSHTML.HTMLDocument, table As MSHTML.htmltable
    'required VBE (Alt+F11) > Tools > References > Microsoft HTML Object Library ;  Microsoft XML, v6 (your version may vary)

    Set xhr = New MSXML2.XMLHTTP60
    Set html = New MSHTML.HTMLDocument
    '  7NXBG2 ;  8QT2E3

    With xhr
        .Open "GET", "https://www.chrono24.com/watch/8QT2E3", False
        .send
        html.body.innerHTML = .responseText
    End With

    Set table = html.querySelector(".specifications table")

    Dim results(), rowCountToExclude As Long

    rowCountToExclude = html.querySelectorAll(".specifications table [colspan='2']").Length
    ReDim results(1 To table.rows.Length - rowCountToExclude, 1 To table.getElementsByTagName("tr")(0).Children(0).getAttribute("colspan"))

    Dim r As Long, c As Long, outputRow As Long, outputColumn As Long, html2 As MSHTML.HTMLDocument

    Set html2 = New MSHTML.HTMLDocument

    For r = 0 To table.getElementsByTagName("tr").Length - 1
        Dim row As Object

        Set row = table.getElementsByTagName("tr")(r)
        html2.body.innerHTML = "<body> <table>" & row.outerHTML & "</table></body> "

        If html2.querySelectorAll("[colspan='2']").Length = 0 Then
            outputRow = outputRow + 1: outputColumn = 1
            For c = 0 To row.getElementsByTagName("td").Length - 1
                results(outputRow, outputColumn) = row.getElementsByTagName("td")(c).innerText
                outputColumn = outputColumn + 1
            Next
        End If
        Set row = Nothing
    Next

    results = Application.Transpose(results)
    ActiveSheet.Cells(1, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...