使用 Excel 数据搜索网站以提取结果，然后循环

Question

我在 Excel 电子表格中有 8000 个值。

我需要搜索一个网站，然后在 Excel 电子表格中记录该网站的特定数据行。

我找到了搜索数据excel macro to search a website and extract results的代码

Sub URL_Get_ABN_Query()
    strSearch = Range("a1")
    With ActiveSheet.QueryTables.Add( _           
      Connection:="URL;http://www.abr.business.gov.au/SearchByABN.aspx?SearchText=" & _
      strSearch & "&safe=active", _
      Destination:=Range("a5"))

        .BackgroundQuery = True
        .TablesOnlyFromHTML = True
        .Refresh BackgroundQuery:=False
        .SaveData = True
    End With
    'enter code here
End Sub

它像这样从网站收集数据。

我只想要“实体类型”数据行。

我找不到如何将代码扩展为只抓取这一行并输入到相应的单元格。即ABN(b2)搜索，找到输入“实体类型”并粘贴到公司类型(c2)中。

另外，我试图找到如何垂直而不是水平填充信息。我可以删除不需要的列。我认为这可能更简单。

我尝试用开发者录制宏。

我还需要循环到下一个 ABN 并填充相应的字段等等（B3>C3、B4>C4 等）。

Answer 1

这是绝对可能的。你已经得到了我经常发现的最困难的部分，即从另一个平台获取信息。为了完成这项工作，我会将其分开一点，为简单起见，使用 2 张工作表（Sheet1 包含您的已知数据，Sheet2 用于 Web 数据）。

遍历您的约 8000 家企业的表格。我们可以从 UsedRange 的行数中识别这一点。我们知道 ABN 在第 2 列（也称为 B）中，因此我们将其复制到变量中以传递给函数。该函数会将“实体类型：”返回到同一行的第 3 (C) 列。

Sub LoopThroughBusinesses() 
    Dim i As Integer
    Dim ABN As String
    For i = 2 To Sheet1.UsedRange.Rows.Count
        ABN = Sheet1.Cells(i, 2)
        Sheet1.Cells(i, 3) = URL_Get_ABN_Query(ABN)
    Next i
End Sub

将您创建的子例程更改为函数，以便它返回您所追求的实体类型。该函数会将数据保存到 Sheet2 中，然后只返回我们需要的实体数据。

Function URL_Get_ABN_Query(strSearch As String) As String   ' Change it from a Sub to a Function that returns the desired string
    ' strSearch = Range("a1") ' This is now passed as a parameter into the Function
    Dim entityRange As Range
    With Sheet2.QueryTables.Add( _
            Connection:="URL;http://www.abr.business.gov.au/SearchByABN.aspx?SearchText=" & strSearch & "&safe=active", _
            Destination:=Sheet2.Range("A1"))   ' Change this destination to Sheet2

        .BackgroundQuery = True
        .TablesOnlyFromHTML = True
        .Refresh BackgroundQuery:=False
        .SaveData = True
    End With

    ' Find the Range that has "Entity Type:"
    Set entityRange = Sheet2.UsedRange.Find("Entity type:")

    ' Then return the value of the cell to its' right
    URL_Get_ABN_Query = entityRange.Offset(0, 1).Value2

    ' Clear Sheet2 for the next run
    Sheet2.UsedRange.Delete

End Function

Answer 2

您不希望以这种方式设置大量连接（查询表）。如果可能的话，它会很慢。在 8000 个请求时，如果 xmlhttp 没有被阻止或限制，下面的方法将明显更快。如果确实出现变慢/阻塞，则每 x 个请求添加一个小等待。

如果可能的话，使用 xmlhttp 来收集数据。使用css selectors 专门针对实体类型。将值存储在一个数组中，并在最后用循环写出。使用一个类来保存 xmlhttp 对象以提高效率。为您的班级提供包括如何处理未找到的方法（给出的示例）。添加一些进一步的优化，例如给出的是关闭屏幕更新。这假设您的搜索号码在 B2 的 B 列中。下面的代码还对 B 列中是否存在某些内容进行了一些基本检查，并处理存在 1 个或多个数字的情况。

好的代码是模块化的，你想要一个函数返回一些东西，一个子函数来执行操作。单个子/功能不应该完成很多任务。您想使用遵循single responsibility（或接近它）原则的代码轻松调试。

类 clsHTTP

Option Explicit

Private http As Object  
Private Sub Class_Initialize()
    Set http = CreateObject("MSXML2.XMLHTTP")
End Sub

Public Function GetHTML(ByVal URL As String) As String
    Dim sResponse As String
    With http
        .Open "GET", URL, False
        .send
        GetHTML = StrConv(.responseBody, vbUnicode)
    End With
End Function

Public Function GetEntityType(ByVal html As HTMLDocument) As String
    On Error GoTo errhand:
     GetEntityType = html.querySelector("a[href*='EntityTypeDescription']").innerText
    Exit Function
errhand:
    GetEntityType = "Not Found"
End Function

标准模块：

Option Explicit 
Public Sub GetInfo()
    Dim http As clsHTTP, sResponse As String, lastRow As Long, groupResults(), i As Long, html As HTMLDocument
    Set html = New HTMLDocument
    Set http = New clsHTTP
    Const BASE_URL As String = "http://www.abr.business.gov.au/ABN/View/"
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        lastRow = .Cells(.rows.Count, "B").End(xlUp).Row
        Select Case lastRow
        Case 1
            Exit Sub
        Case 2
            ReDim arr(1, 1): arr(1, 1) = .Range("B2").Value
        Case Else
            arr = .Range("B2:B" & lastRow).Value
        End Select

        ReDim groupResults(1 To lastRow - 1)

        With http
            For i = LBound(arr, 1) To UBound(arr, 1)
                If Len(BASE_URL & arr(i, 1)) > Len(BASE_URL) Then
                    sResponse = .GetHTML(BASE_URL & arr(i, 1))
                    html.body.innerHTML = sResponse
                    groupResults(i) = .GetEntityType(html)
                    sResponse = vbNullString: html.body.innerHTML = vbNullString
                End If
            Next
        End With
        For i = LBound(groupResults) To UBound(groupResults)
            .Cells(i + 1, "C") = groupResults(i)
        Next
    End With
    Application.ScreenUpdating = True
End Sub

---

参考资料（VBE> 工具 > 参考资料）：

1. Microsoft HTML 对象库

---

CSS 选择器：

我使用实体描述是一个超链接（a 标记）这一事实，并且它的值包含字符串 EntityTypeDescription 以使用带有包含 (*) 运算符的 css 属性 = 值来定位。