VBA在excel中获取自定义数据[关闭]

Question

我正在尝试完全按照此视频中的内容进行操作。 https://www.youtube.com/watch?v=MswEPIFTEVU

Answer 1

您可以改用XMLHTTP request 来获取数据，这要快得多。这假设您的链接位于从单元格 A1 开始的 A 列工作表 1 中。 它获取电话号码并将它们返回到链接旁边的 B 列。 如果您有大量链接，则此方法比您正在考虑的方法更有效。

Option Explicit
Public Sub GetInfo()
    Dim i As Long, html As HTMLDocument, links(), http As Object, results(), URL As String
    Dim lastRow As Long
    With Worksheets("Sheet1")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'URL are in column A sheet 1, starting at A1

        If lastRow = 1 Then
            ReDim links(1, 1): links(1, 1) = .Range("A1")
        Else
            links = .Range("A1:A" & lastRow).Value
        End If

        ReDim results(0 To UBound(links, 1) - 1)
        Set http = CreateObject("MSXML2.XMLHTTP")

        For i = LBound(links) To UBound(links)
            If InStr(links(i, 1), "http") > 0 Then
                URL = links(i, 1)
                Set html = GetHTMLDoc(http, URL)
                results(i - 1) = GetNumber(html)
                Set html = Nothing
            End If
        Next
        .Range("B1").Resize(UBound(results, 1) + 1, 1) = Application.WorksheetFunction.Transpose(results)
    End With

End Sub
Public Function GetHTMLDoc(ByVal http As Object, ByVal URL As String) As HTMLDocument
    Dim html As New HTMLDocument, sResponse As String
    With http
        .Open "GET", URL, False
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With

    html.body.innerHTML = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))

    Set GetHTMLDoc = html
End Function
Public Function GetNumber(ByVal html As HTMLDocument) As String
    Dim arr() As String
    arr = Split(html.querySelector(".container").innerText, Chr$(10))
    GetNumber = Replace$(arr(8), "Number : +", vbNullString)
End Function

---

你可以重写如下得到城市、名称、运营商

Option Explicit
Public Sub GetInfo()
    Dim i As Long, html As HTMLDocument, links(), http As Object, results(), URL As String
    Dim lastRow As Long
    With Worksheets("Sheet1")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'URL are in column A sheet 1, starting at A1

        If lastRow = 1 Then
            ReDim links(1, 1): links(1, 1) = .Range("A1")
        Else
            links = .Range("A1:A" & lastRow).Value
        End If

        ReDim results(0 To UBound(links, 1) - 1)
        Set http = CreateObject("MSXML2.XMLHTTP")

        For i = LBound(links) To UBound(links)
            If InStr(links(i, 1), "http") > 0 Then
                URL = links(i, 1)
                Set html = GetHTMLDoc(http, URL)
                results(i - 1) = GetNumber(html)
                Set html = Nothing
            End If
        Next

        For i = LBound(results) To UBound(results)
            .Cells(i + 1, 2).Resize(1, UBound(results(i)) + 1) = results(i)
        Next
    End With

End Sub
Public Function GetHTMLDoc(ByVal http As Object, ByVal URL As String) As HTMLDocument
    Dim html As New HTMLDocument, sResponse As String
    With http
        .Open "GET", URL, False
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With

    html.body.innerHTML = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))

    Set GetHTMLDoc = html
End Function
Public Function GetNumber(ByVal html As HTMLDocument) As Variant
    Dim arr() As String, outputArr(0 To 2)
    arr = Split(html.querySelector(".container").innerText, Chr$(10))
    outputArr(0) = Replace$(arr(2), "Name : ", vbNullString)
    outputArr(1) = Replace$(arr(10), "Carrier : ", vbNullString)
    outputArr(2) = Replace$(arr(14), "City : ", vbNullString)
    GetNumber = outputArr
End Function

如果由于某种原因位置匹配不起作用，您可以使用以下版本的函数GetNumber：

Public Function GetNumber(ByVal html As HTMLDocument) As Variant
    Dim arr() As String, outputArr(0 To 2), i As Long
    arr = Split(html.querySelector(".container").innerText, Chr$(10))
    For i = LBound(arr) To UBound(arr)
    Select Case True
        Case InStr(arr(i), "Name") > 0
            outputArr(0) = Replace$(arr(2), "Name : ", vbNullString)
        Case InStr(arr(i), "Carrier") > 0
            outputArr(1) = Replace$(arr(10), "Carrier : ", vbNullString)
        Case InStr(arr(i), "City") > 0
            outputArr(2) = Replace$(arr(14), "City : ", vbNullString)
        End Select
    Next i
    GetNumber = outputArr
End Function