excel - 如何用VBA和选择器将该网站的内容导出到Excel？

Question

我的网站问题:

虽然数据定期变化，但数据的结构始终保持不变。我尝试将内容(仅带有标题的最后两列:Aktenzeichen 和 Aufgehoben)传输到 excel 3 列(ID 号、日期、时间) ) 通过将 Aufgehoben 的值拆分为日期和时间。

我的问题是“Bundesland”和“Amtsgericht”列中的值(即使我不需要这些)与其他数据的出现频率不同并且困惑html 结构中的所有 trs 和 tds，所以我不明白如何使用选择器!有任何想法吗？谢谢。

我的...嗯...代码:

Sub GetData()

    Const URL = "https://www.zvg.com/appl/aufgehoben.prg?act=getHTML"
    Dim html As New HTMLDocument
    Dim elmt As Object
    Dim x As long

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .send
        html.body.innerHTML = .responseText
    End With
                   
     For x = 0 to ????.Length - 1
     Set elmt = html.querySelectorAll("???")
       ActiveSheet.Cells(y + 2, 2) = elmt.Item(?).innerText  'Aktenzeichen
       ActiveSheet.Cells(y + 2, 3) = elmt.Item(?).innerText  'Date
       ActiveSheet.Cells(y + 2, 4) = elmt.Item(?).innerText  'Time
     Next

End Sub

Answer 1

我可以向您保证可能有比这更好的答案，但以下代码有效:

Sub getStuff()

' Declare variables
Dim XMLPage As New MSXML2.XMLHTTP60
Dim HTMLDoc As New MSHTML.HTMLDocument
Dim Table, Row, Data, Point As Variant
Dim i, x, j As Integer

' Make Request
With XMLPage
    .Open "GET", "https://www.zvg.com/appl/aufgehoben.prg?act=getHTML", False
    .send
    HTMLDoc.body.innerHTML = .responseText
End With

' Set counters
i = 1
x = 0
j = 1

' Parse data into worksheet
For Each Table In HTMLDoc.getElementsByTagName("tr")
    For Each Row In Table.getElementsByTagName("tr")
        For Each Data In Row.getElementsByTagName("td")
            ' Parse headers in first run
            If i = 1 Then
                Cells(i, j).Value = Data.innerText
            Else
                x = i
                ' Split the data points
                For Each Point In Split(Data.innerText, Chr(13))
                    Cells(i, j).Value = Point
                    i = i + 1
                Next Point
                If j <> 3 Then
                    i = x
                End If
            End If
            j = j + 1
        Next Data
    i = i + 1
    j = 1
    Next Row
Next Table

' Remove empty rows
Columns("C:C").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete

End Sub