VBA将内部文本从html页面传输到excel

Question

这张图片显示了我使用下面的宏

但此代码在打开两三个 URL 后停止，我们看到以下错误消息，
1.运行时错误91
2. 对象变量或块未设置

Sub test()

Dim wb As Object
Dim doc As Object
Dim sURL As String
Dim lastrow As Long
Dim n As Integer
Dim i As Integer
Dim HtmlToText As String
Dim result
lastrow = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To lastrow  'Start the loop on the second row of column A. Until the last URL..

    Set wb = CreateObject("internetExplorer.Application")
    sURL = Cells(i, 1)
    wb.navigate sURL
    wb.Visible = False
    While wb.Busy
      DoEvents
    Wend
    'HTML document
    Set doc = wb.document
    Dim Name As Variant
    Dim Posts As Variant
    Dim Followers As Variant
    Dim Following As Variant
    Dim DivValue As Variant
    Dim DivValueSplit As Variant
    Dim DivValueResult As Variant
    Dim Biography As Variant

    Name = doc.getElementsByClassName("AC5d8 notranslate")(0).innerText
    Posts = doc.getElementsByClassName("g47SY")(0).innerText
    Followers = doc.getElementsByClassName("g47SY")(1).innerText
    Following = doc.getElementsByClassName("g47SY")(2).innerText
    'dd = web.document.querySelector("div.-vDIg span").innerText
    DivValue = doc.getElementsByClassName("-vDIg")(0).innerText

    'DivValueSplit = Split(DivValue, "<br>")
    'If UBound(DivValueSplit) = 2 Then
    '   DivValueResult = DivValueSplit(1) & DivValueSplit(2)
     '  j = InStr(DivValueResult, "</span>")
      ' Biography = Mid(DivValueResult, 7, j - 7)
    'ElseIf sURL = "https://www.instagram.com/philipplein/" Then
     ' DivValueResult = DivValueSplit(0)
      'j = InStr(DivValueResult, "</h1>")
      'Biography = Mid(DivValueResult, 19, j - 5)
    'Else
     '   DivValueResult = DivValueSplit(1)
      '  j = InStr(DivValueResult, "</span>")
       ' Biography = Mid(DivValueResult, 7, j - 7)
    'End If

    Worksheets("sheet1").Cells(i, 2) = Name
    Worksheets("sheet1").Cells(i, 3) = Followers
    Worksheets("sheet1").Cells(i, 4) = Following
    Worksheets("sheet1").Cells(i, 5) = Posts
    Worksheets("sheet1").Cells(i, 6) = DivValue
    'Biography = Replace(re1, "<span>", "")

    'Cells(i, 2) = HtmlToText
    ' myarray = Split(Data, vbCrLf)
err_clear:



      If Err <> 0 Then
          Err.Clear
          Resume Next
        End If
        wb.Quit
    Next i

End Sub

Answer 1

大纲：

两种方法。一个没有打开浏览器，发出XMLHTTP request，另一个使用Internet Explorer。

如果有一种 API 方法可以完成这项工作，我肯定会采用这种方法。以下 2 种方法目前适用于您显示的所有网址。

注意：

这些基于工作表中 URL 的结尾部分，即人名。见底部图片。

XMLHTTP 请求：

这使用自定义类clsHTTP 来保存XMLHTTP object。它有2种方法。一，GetString，发出请求并解析出响应的一部分。另一个，GetInfo，获取GetString返回的字符串，解析出感兴趣的元素，并以数组的形式返回。

待办事项：

可以开发类。它是光秃秃的骨头。特别是，它可以添加错误处理，例如处理服务器连接丢失。

VBA：

班级clsHTTP:

Option Explicit

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

Public Function GetString(ByVal URL As String) As String
    Dim sResponse As String
    With http
        .Open "GET", URL, False
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
        GetString = Split(Split(sResponse, "ProfilePage"":")(1), "comments_disabled")(0)   
    End With
End Function

Public Function GetInfo(ByVal sResponse As String) As Variant
    Dim results(0 To 4)
    'Name, Followers,  Following,Posts,Biography
    On Error Resume Next
    results(0) = Split(sResponse, """full_name"":""")(1)
    results(1) = Split(Split(sResponse, """count"":")(1), "}")(0)
    results(2) = Split(Split(sResponse, """count"":")(2), "}")(0)
    results(3) = Split(Split(sResponse, """count"":")(4), ",")(0)
    results(4) = Split(Split(sResponse, """biography"":""")(1), """,")(0)
    On Error GoTo 0
    GetInfo = results
End Function

标准模块module 1:

Option Explicit
Public Sub GetInfo()
    Dim http As clsHTTP, sResponse As String, lastRow As Long, groupResults()
    Set http = New clsHTTP
    Const BASE_URL As String = "https://www.instagram.com/"

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

        ReDim groupResults(0 To lastRow - 2)
        Dim results(0 To 4), counter As Long, i As Long
        With http
            For i = LBound(arr, 1) To UBound(arr, 1)
                If Len(BASE_URL & arr(i, 1)) > Len(BASE_URL) Then
                     sResponse = .GetString(BASE_URL & arr(i, 1))
                    groupResults(counter) = .GetInfo(sResponse)
                    sResponse = vbNullString
                    counter = counter + 1
                End If
            Next
        End With

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

---

Internet Explorer：

稍后我会写一些更好的东西，但是下面将循环放置在您创建 Internet Explorer 对象的位置，这样您就不会继续创建和销毁。它引入了等待元素出现以及页面加载。

---

待办事项：

我会做一些初步的改变：

1. 重构代码以具有处理数据提取的单独函数/子程序；
2. 添加方法来管理失败的连接/超时。

---

VBA：

Option Explicit
Public Sub GetInfo()
    Dim IE As New InternetExplorer, lastRow As Long, arr(), groupResults()

    Const BASE_URL As String = "https://www.instagram.com/"

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

        ReDim groupResults(0 To lastRow - 2)
        Dim results(0 To 4), counter As Long, i As Long
        With IE
            .Visible = True

            For i = LBound(arr, 1) To UBound(arr, 1)
                If Len(BASE_URL & arr(i, 1)) > Len(BASE_URL) Then
                    .navigate BASE_URL & arr(i, 1)

                    While .Busy Or .readyState < 4: DoEvents: Wend
                    'Name, Followers,  Following,Posts,Biography
                    Dim aNodeList As Object, ele As Object, t As Date
                    Const MAX_WAIT_SEC As Long = 5

                    t = Timer

                    Do
                        DoEvents
                        On Error Resume Next
                        Set ele = .document.querySelector(".rhpdm")
                        On Error GoTo 0
                        If Timer - t > MAX_WAIT_SEC Then Exit Do
                    Loop While ele Is Nothing

                    '   Application.Wait Now + TimeSerial(0, 0, 2)
                    results(0) = ele.innerText
                    Set aNodeList = .document.querySelectorAll(".g47SY")
                    results(1) = aNodeList.item(0).innerText
                    results(2) = aNodeList.item(1).innerText
                    results(3) = aNodeList.item(2).innerText
                    results(4) = .document.querySelector(".rhpdm ~ span").innerText
                    Set aNodeList = Nothing : Set ele = Nothing
                    groupResults(counter) = results
                    counter = counter + 1
                End If 
            Next        
            .Quit '<== Remember to quit application
        End With

        For i = LBound(groupResults) To UBound(groupResults)
            .Cells(2 + i, "B").Resize(1, UBound(results) + 1) = groupResults(i)
        Next

    End With
End Sub

---

结果：