从网站列表中抓取数据

Question

`我正在尝试抓取数据，例如

成立日期、电子邮件地址、地址和董事详细信息 来自https://www.zaubacorp.com/company-list/nic-300-company.html 中的 500 个网站列表，该列表扩展到许多页面。我需要提取网站，这是我在 Excel 中使用 Power Query 完成的，但是从每个网站中提取特定细节在 Power Query 中是一项繁琐的工作。

另外，问题在于电子邮件地址和地址，无法找到类/标签 ID 名称。（这是我最近得到的，但现在我需要大量网站的帮助，代码应该适用于所有人网站（因为它们在特定位置具有相同类型的数据。

Sub GetInfo()
    Const URL = "https://www.zaubacorp.com/company/TECHDRIVE-SOFTWARE-LIMITED/U30007DL1999PLC356280"
    Dim Html As New HTMLDocument
    Dim elem As Object, adr As Object

    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", URL, False
        .send
        Html.body.innerHTML = .responseText
    End With

    For Each elem In Html.getElementsByTagName("b")
        If InStr(elem.innerText, "Email ID:") > 0 Then
            [A2] = elem.ParentNode.innerText
            Exit For
        End If
    Next elem

    For Each adr In Html.getElementsByTagName("b")
        If InStr(adr.innerText, "Address:") > 0 Then
            [B2] = adr.ParentNode.NextSibling.innerText
            Exit For
        End If
    Next adr
End Sub

Answer 1

我已修改您现有的脚本以遍历多个页面，现在可以从那里提取每个容器的name、Date of Incorporation、email 和address。确保在执行以下脚本之前创建一个名为 DataContainer 的工作表。

Sub GetInfo()
    Const prefix$ = "https://www.zaubacorp.com/company-list/nic-300/p-"
    Const suffix$ = "-company.html"
    Dim Html As New HTMLDocument, Htmldoc As New HTMLDocument
    Dim newHtml As New HTMLDocument, newUrl$, elem As Object, oDate As Object, R&, I&
    Dim Wb As Workbook, ws As Worksheet, adr As Object, P&, pageNum&

    Set Wb = ThisWorkbook
    Set ws = Wb.Worksheets("DataContainer") '----------->create a sheet and name it `DataContainer` in order for the script to write the results in there

    For pageNum = 1 To 2  '---------------------------------> this is where you put the highest number the script will traverse
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", prefix & pageNum & suffix, False
            .send
            Html.body.innerHTML = .responseText
        End With

        With Html.querySelectorAll("#table tbody tr")
            For I = 0 To .Length - 1
                Htmldoc.body.innerHTML = .item(I).outerHTML
                newUrl = Htmldoc.querySelector("a[href]").getAttribute("href")

                With CreateObject("MSXML2.XMLHTTP")
                    .Open "GET", newUrl, False
                    .send
                    newHtml.body.innerHTML = .responseText
                End With

                R = R + 1: ws.Cells(R, 1) = newHtml.querySelector(".container > h1").innerText

                For Each oDate In newHtml.getElementsByTagName("p")
                    If InStr(oDate.innerText, "Date of Incorporation") > 0 Then
                        ws.Cells(R, 2) = oDate.ParentNode.NextSibling.innerText
                        Exit For
                    End If
                Next oDate

                For Each elem In newHtml.getElementsByTagName("b")
                    If InStr(elem.innerText, "Email ID:") > 0 Then
                        ws.Cells(R, 3) = elem.ParentNode.innerText
                        Exit For
                    End If
                Next elem

                For Each adr In newHtml.getElementsByTagName("b")
                    If InStr(adr.innerText, "Address:") > 0 Then
                        ws.Cells(R, 4) = adr.ParentNode.NextSibling.innerText
                        Exit For
                    End If
                Next adr
            Next I
        End With
    Next pageNum
End Sub