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

但是，当我运行Excel宏时，它将像这样从网站收集所有数据。

我只希望输入“实体类型”数据行。我到处搜索，似乎无法找到如何扩展代码以仅获取这行信息并将其输入到相应单元格的方法（即ABN（b2）搜索，找到输入“实体类型”并粘贴到Company Type（c2）中）

或者，我也试图找到如何使宏垂直而不是水平地填充信息，因为这样我可以删除不需要的列，我认为这可能是运行此宏的更简单方法，但是我再次找不到帮助。我还尝试与开发人员一起记录宏，但是那也不起作用。

我还需要循环运行下一个ABN并填充相应的字段，依此类推（例如B3> C3，B4> C4等）

我很想帮助弄清楚，我是VBA的初学者，并且认为我想做的事目前超出了我的技能水平。我试图通过教程，谷歌搜索和帮助页面来理解，但似乎找不到如何或是否可以这样做。

我的替代方法是为8000个数据点中的每个手动进行此操作，然后复制每个abn，在网站中进行搜索，然后复制实体类型并粘贴到excel中，我确实先尝试了此方法，但过了一会儿开始搜索更好的方法。你能帮忙吗？???

Answer 1

这是绝对可能的。您拥有了我经常发现的最困难的部分，即从另一个平台获取信息。为了完成这项工作，我将它分开一点，为简单起见，请使用2张纸（带有已知数据的Sheet1和Web数据的Sheet2）。

遍历约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

将您创建的子例程更改为Function，以便它返回您所追求的实体类型。该函数会将数据保存到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

您不希望以这种方式设置大量的连接（queryTables）。即使可能，它也会如此缓慢。如果未阻止或限制xmlhttp，则在8000个请求时，以下方法将明显更快。如果确实确实在变慢/阻塞，则每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>工具>参考）：

Microsoft HTML对象库

CSS选择器：

我使用以下事实：实体描述是超链接（a标记），并且其值包含字符串EntityTypeDescription，以将css attribute = value包含（*）运算符用于目标。 / p>

Excel宏可使用Excel数据搜索网站并提取特定结果，然后循环查找下一个值

2 个答案: