Get HTML content with variable tags and extract innertext with VBA for EXcel

You could extract the links to the detail documents during a post request then visit each of those links with internet explorer, ensuring to provide the right referer header; then use regex to grab that measurement.

TODO: Code really needs a re-factor as there is a lot going on in the main sub. Really each sub/function should be doing c. one thing.

Option Explicit

Public Sub GetDataZvgPort()
    Const URL = "https://www.zvg-portal.de/index.php?button=Suchen"
    Dim html As MSHTML.HTMLDocument, xhr As Object

    Set html = New MSHTML.HTMLDocument
    Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0")

    With xhr
        .Open "POST", URL, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .send "land_abk=ni&ger_name=Peine&order_by=2&ger_id=P2411"
        html.body.innerHTML = .responseText
    End With

    Dim table As MSHTML.HTMLTable, r As Long, c As Long, headers(), row As MSHTML.HTMLTableRow
    Dim results() As Variant, html2 As MSHTML.HTMLDocument

    headers = Array("Aktenzeichen", "Amtsgericht", "Objekt/Lage", "Verkehrswert in €", "Termin", "Pdf-Link", "Addit Info Link", "m²")

    ReDim results(1 To 100, 1 To UBound(headers) + 1)

    Set table = html.querySelector("table")
    Set html2 = New MSHTML.HTMLDocument

    Dim lastRow As Boolean

    For Each row In table.Rows
        lastRow = False
        Dim header As String

        html2.body.innerHTML = row.innerHTML
        header = Trim$(row.Children(0).innerText)

        If header = "Aktenzeichen" Then          'start of new block. Assumes all blocks have this
            r = r + 1
            Dim dict As Scripting.Dictionary: Set dict = GetBlankDictionary(headers)
            On Error Resume Next
            dict("Addit Info Link") = Replace$(html2.querySelector("a").href, "about:", "https://www.zvg-portal.de/")
            On Error GoTo 0
        End If

        If dict.Exists(header) Then dict(header) = Trim$(row.Children(1).innerText)

        If (header = vbNullString And html2.querySelectorAll("a").Length > 0) Then
            dict("Pdf-Link") = Replace$(html2.querySelector("a").href, "about:blank", "https://www.zvg-portal.de/index.php")
            lastRow = True
        ElseIf header = "Termin" Then
            If row.NextSibling.NodeType = 1 Then lastRow = True
        End If

        If lastRow Then
            populateArrayFromDict dict, results, r
        End If
    Next

    results = Application.Transpose(results)
    ReDim Preserve results(1 To UBound(headers) + 1, 1 To r)
    results = Application.Transpose(results)
    
    Dim re As Object
    
    Set re = CreateObject("VBScript.RegExp")
    
    With re
        .Global = False
        .MultiLine = False
        .IgnoreCase = True
        .Pattern = "\s([0-9.]+)\sm²"
    End With

    Dim ie As SHDocVw.InternetExplorer
    
    Set ie = New SHDocVw.InternetExplorer
    
    With ie
        .Visible = True
        
        For r = LBound(results, 1) To UBound(results, 1)
            
            If results(r, 7) <> vbNullString Then
                
                .Navigate2 results(r, 7), headers:="Referer: " & URL
                
                While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
 
                'On Error Resume Next
                results(r, 8) = re.Execute(.document.querySelector("#anzeige").innerHTML)(0).Submatches(0)
                'On Error GoTo 0
   
            End If
            
        Next
        
        .Quit
        
    End With
    
    With ActiveSheet
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With

End Sub

Public Sub populateArrayFromDict(ByVal dict As Scripting.Dictionary, ByRef results() As Variant, ByVal r As Long)
    Dim key As Variant, c As Long

    For Each key In dict.Keys
        c = c + 1
        results(r, c) = Replace$(dict(key), " (Detailansicht)", vbNullString)
    Next

End Sub

Public Function GetBlankDictionary(ByRef headers() As Variant) As Scripting.Dictionary
    Dim dict As Scripting.Dictionary, i As Long

    Set dict = New Scripting.Dictionary

    For i = LBound(headers) To UBound(headers)
        dict(headers(i)) = vbNullString
    Next

    Set GetBlankDictionary = dict
End Function