Masalah saya dengan situs web:

Meskipun data berubah secara teratur, struktur data selalu tetap sama. Saya mencoba mentransfer konten (hanya dua kolom terakhir dengan tajuk: Aktenzeichen dan Aufgehoben) ke excel dalam 3 kolom (Nomor ID, Tanggal, Waktu ) dengan membagi nilai Aufgehoben dalam tanggal dan waktu.

Masalah saya adalah bahwa nilai di kolom "Bundesland" dan "Amtsgericht" (walaupun saya tidak membutuhkannya) memiliki frekuensi kemunculan yang berbeda dari data lainnya dan mengacaukan semua trs dan tds di struktur html jadi saya tidak mengerti cara menggunakan penyeleksi! Ada ide? TERIMA KASIH.

Saya...mmm...kode:

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
2
Jasco 18 Mei 2021, 22:28

1 menjawab

Jawaban Terbaik

Saya dapat meyakinkan Anda bahwa mungkin ada jawaban yang lebih baik dari ini, tetapi kode berikut berfungsi:

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
1
Christopher Weckesser 18 Mei 2021, 21:14