将 HTML 内容传输到 Excel

Question

如何使用 vba 将 顶部和底部 TR-tag 之间的所有内部文本（包括此 sn-p 中的 HREF 链接）传输到 ONE excel 单元格？ TR-tag 是主 TABLE-tag 下的最外层标签。使用此代码，我可以在多个单元格中传输每个 TR 或 TD 的内部文本。将内容传输到一个 Excel 单元格后，我将尝试使用字符串操作将文本部分分离并传输到不同的单元格。

Set element = html.querySelectorAll("tr")   'or td
For L = 0 To element.Length - 1
ActiveSheet.Cells(x + 2, 2) = element.Item(x).innerText
Next x

最好将每个文本行放入 Excel 单元格，但水平排列！（单元格 a、b、c...）作为一行直到下一个“TR 到 TR部分”，它必须从 Excel 中的下一行/行 (1,2,3...) 开始。 （我试图在这里建立一个适当的表格，因为 HTML 中的每条记录都包含多个内容，如下所示。）还有一个问题是每个文本都在另一个标签内：“nobr”、“b”、“p”，有些只是在“td”中。

这是他的sn-p。

<tr>
    <td valign="top" align="left">
        <nobr>TEXT&nbsp;&nbsp;</nobr>
    </td>
    <td valign="center" align="left">
        <b>
            <a target="_blank" href="idx.php?button=showZvg&ndd_id=2444&land_nve=lv">
                <nobr>TEXT8&nbsp;(Detailansicht)</nobr>
            </a>
        </b>
        &nbsp;
    </td>
    <td valign="top" align="right">
        <nobr>TEXT</nobr>
    </td>
</tr>
<tr>
    <td valign="top" align="left">TEXT</td>
    <td colspan="2" valign="center" align="left">
        <b>TEXT</b>
    </td>
</tr>
<tr>
    <td valign="top" align="left">TEXT</td>
    <td colspan="2" valign="center" align="left">
        <b>
            TEXT
        </b>
        TEXT
    </td>
</tr>
<tr>
    <td valign="top" align="left">
        <nobr>TEXT</nobr>
    </td>
    <td colspan="2" valign="center" align="left">
        <b>
            <p>TEXT</p>
        </b>
    </td>
</tr>
<tr>
    <td valign="top" align="left">Termin</td>
    <td valign="center" align="left">TEXT</td>
</tr>

Answer 1

您想转置表格，但表格不规则。我假设当有超过 2 个子节点时，您希望将该文本合并到一个单元格中：

Dim table As MSHTML.HTMLTable, row As MSHTML.HTMLTableRow, column As MSHTML.HTMLTableCell
Dim r As Long, c As Long

Set table = html.querySelector("table")

With ActiveSheet
    r = 1
    For Each row In table.Rows
         c = 1
         Dim combined As String: combined = vbNullString
         For Each column In row.Children
             If row.Children.Length > 2 And c > 1 Then
               combined = combined & Chr$(32) & Trim$(column.innerText)
             Else
                 .Cells(IIf(c = 1, 1, c), r) = Trim$(column.innerText)
             End If
             If row.Children.Length > 2 And c = row.Children.Length Then
                 .Cells(row.Children.Length - 1, r) = Trim$(combined)
             End If
             c = c + 1
        Next
        r = r + 1
    Next
End With

---

根据实际情况：

1. 由于表的扁平兄弟结构（即不能轻易划分为结果块（可能除了空白行）我处理所有行，每次看到 “Aktenzeichen”将输出行计数器加 1。
2. 增量之间的所有行都将为当前行列提供数据。
3. 有一个字典，其中所有可能的标题作为键，vbNullString 作为值；作为循环行，将当前标题设置为第一列值并将相邻的td 值添加到字典中；反对那个标题。如果标题为空白，而不是空白行，请查找 a 标记链接 (Pdf-Link)。
4. 每次行增量时都会抓取一个新的空白字典（具有键但 nullString 值）。
5. 在再次增加行之前，将当前行清空为一个过大的数组。一旦知道标头并估计更多的预期结果数量，该数组的大小就会被确定。 results 数组与当前行号一起传递 ByRef，以便它可以由单独的子更新。
6. 最后，在处理完所有行之后，results 数组以所需的表格格式写入工作表。标题会添加到上面写入结果的行中。

注意：我认为下载 pdf 仍然需要 selenium basic。

---

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")

    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)
        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)

    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