将HTML内容传输到Excel

如何使用vba将顶部和底部TR标记之间的所有内部文本（包括此代码段中的HREF链接）传输到一个excel单元格？TR标记是主表标记下的最外层标记。有了这段代码，我就可以在多个单元格中传输每个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”中

这是他的片段

正文
正文
正文
正文
正文
正文
正文
正文
正文

终点站
正文

您想转置表格，但表格不规则。我假设当有两个以上的子节点时，您希望将该文本合并并放置到单个单元格中：

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

---

根据实际情况：

由于表的平面同级结构（即不能很容易地划分为结果块（除了空白行），我处理所有行，每次都看到 “Aktenzeichen”将输出行计数器增加1

增量之间的所有行将提供当前行列的数据

拥有一个字典，其中所有可能的标题都作为键，

vbNullString

作为值；作为循环行，将当前标题设置为第一列值，并将相邻的

td

值添加到字典中；相对于该标题。如果标题为空，而不是空行，请查找

a

标记链接（

Pdf链接

）

每次行增量时，都会抓取一个新的空白字典（具有键但具有空字符串值）

在再次增加行数之前，将当前行清空为一个过大的数组。一旦知道了标题并估计了更多的预期结果数，就会调整此数组的大小。将

结果

数组与当前行数一起传递给

ByRef

，以便可以由单独的子行更新

最后，处理完所有行后，

results

数组将以所需的表格格式写入工作表。标题将添加到上面写入结果的行中

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

---

---

通过剪贴板将粘贴表outerHTML复制到Excel。感谢@QHARR，你是“google x”的秘密计算机科学家吗？；-）使用MSXML2.XMLHTTP复制并粘贴outerHTML效果良好，但是现在我在一个单元格中有了表标记的全部源代码内容……如果复制表标记的outerHTML，那么表应该在excel中复制，而不仅仅是在一个单元格中。旁注：有一家公司x:。谷歌x不能否认或证实。使用链接中的代码复制粘贴，即创建剪贴板对象。没错，这是一个代码错误：我有

ActiveSheet.Cells（1，1）=objCBData.GetText

，但它必须是

ActiveSheet.paste

。但我仍然面临着同样的问题：桌子是垂直排列的！如果使用queryselectorall“td”，我也会得到同样的结果。我需要的结果在行，而不是在列！您可以使用selenium使用python打开浏览器。使用vba@Jasco对不起，我的简短感叹。我只想指出，Selenium也可以作为用于VBA的Selenumbasic提供。您必须确保Seleniumbasic版本与您正在使用的浏览器版本以及相应WebDriver的版本相匹配：@Jasco您必须将图片粘贴到您的帖子中。编辑它。这在评论中是不可能的。@Jasco我的提示：今天就把它留下。今天是星期五，德国是晚上9:10。我知道这一点，因为我也住在德国。我的第二个建议是：不要再删除这个问题。肯定有人想帮你。但要给他们时间这样做。他们在空闲时间完全免费做这件事。我很清楚这一点，因为我已经为你的一个问题编写了程序，但我无法再回答了。非常令人沮丧。我知道你想为你的父母找到解决办法，这是很光荣的。但请不要（为你自己）得意忘形。对不起，这是我的印象。^^这是一些很好的建议。我认为有解决的办法，但我，例如，需要适应这个在考试复习。我明天再来看看。

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