【问题标题】:Avoid crashing VBA when running IE web scraping multiple times多次运行 IE 网页抓取时避免崩溃 VBA
【发布时间】:2019-07-09 07:11:18
【问题描述】:

当我多次抓取网站信息并将其插入单元格时,我的 excel 崩溃

我的代码集中已经包含了 IE = Nothing 和 IE Quit,但这并没有改变代码在多次迭代后返回错误的事实

我的代码由循环部分和实际抓取组成。这是循环:

Public Sub LooperForMMDescription()
Dim currentValue As String
Dim dataList As Variant
Dim i As Integer
Dim n As Integer
Dim FirstRow As Integer
Dim IE As Object
    n = 1
    Set dataList = Range("Table6")
    FirstRow = Range("Table6").Row - 1
    'On Error Resume Next
    Set IE = Nothing

    For i = 1 To UBound(dataList.Value)
        If IsEmpty(dataList.Value) Then
            Exit Sub
        Else
            currentValue = dataList(i, 1).Text
            If Len(currentValue) = 0 Then
            GoTo ByPass
            End If
            Call MM_description(currentValue, n, FirstRow, IE)
ByPass:
            n = n + 1
        End If
    Next i
    Sheets("Input").Range("F7").Select
End Sub

这是实际的抓取:

Public Sub MM_description(currentValue As String, n As Integer, FirstRow As Integer, IE As Object)

Dim html As HTMLDocument
Dim codeLine As String
Dim startPos As Long
Dim endPost As Long

Set IE = Nothing
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False

IE.Navigate2 (currentValue)
Do While IE.Busy
   Application.Wait DateAdd("s", 1, Now)
Loop

mes = IE.document.body.innerHTML
startPos = InStr(mes, "Description") + 61
endPos = InStr(mes, "Address")

If startPos = 0 Then
    Sheets("Input").Range("F" & FirstRow + n).Value = "Not Found"
Else
    codeLine = Mid(mes, startPos, endPos - startPos - 229)
    Sheets("Input").Range("F" & FirstRow + n).Value = codeLine

End If
IE.Quit
Set IE = Nothing

End Sub

代码在 80-90 次迭代中运行良好,但随后返回错误

【问题讨论】:

  • 那个错误是什么,它发生在哪一行?网址是公开的吗?上面有一些问题需要解决。
  • 还有,请问table6是什么样子的?

标签: excel vba web-scraping crash screen-scraping


【解决方案1】:

因此,这与其说是答案,不如说是代码审查。以下是关于您的代码的注释和建议的重写。


使用Long 而不是Integer,因为这样可以降低Integer 数据类型可能发生的溢出风险,尤其是在处理行循环时(行数超过Integer 可以处理的数量)。此外,Integer v Long 对性能没有任何好处。


驼峰局部变量

firstRow 

使用工作表变量提高可读性

Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")

使用显式的工作表引用而不是容易出错的隐式Activesheet 引用。使用上面的ws 变量:

Range("Table6")  

具有隐式 Activesheet 引用可以具有显式工作表引用

ws.Range("Table6")

dataList.value 是一个二维数组,因为您正在从工作表中读取一个范围:

For i = 1 To UBound(dataList.Value)

因此,应该在循环中指定第二个维度,将二维数组读入变量会更有效,而不是重复昂贵的 i/o 以获取值

我不知道您的 table6 是什么样的,但我怀疑您正在尝试循环特定列(可能是第一列)

然后,您可以将表放入一个变量中,然后将其第一列值(不包括标题)读入一维数组以进行循环。由于您稍后将再次将值写入工作表,因此将输出数组的维度设置为与您正在循环的数组相同的维度,以将循环的结果存储在

Dim arr(), table As ListObject, output()

Set table = ws.ListObjects("Table6")
arr = Application.Transpose(table.ListColumns(1).DataBodyRange.Value)

ReDim output(1 To UBound(arr))

这个

If IsEmpty(dataList.Value) Then
    Exit Sub
Else

基本上是看表databodyrange是否为空。假设您正在检查表的第 1 列中是否有任何 url,那么只需要此测试 在循环之前一次,并且可以是一个没有If Else End If的单衬里@

If IsEmpty(arr) Then Exit Sub

考虑将局部变量重命名为更有用/更具描述性的值:currentValuecurrentUrl,因为这对 IMO 更有用。


这个

If Len(currentValue) = 0 Then
    GoTo ByPass
End If

基本上是检查是否有值作为 url 传递并使用 GoTo 来处理不存在的情况。尽可能避免使用 GoTo,因为它会使代码更难阅读。这里不需要。您可以使用快速的vbNullString 比较,甚至更好的Instr(url, "http") > 0 来验证您将使用的值:

(我已经从 currentValue 切换了)

'initial code

If currentUrl <> vbNullString Then  'test
    'call the sub and extract value
End If

n = n + 1 'increment....loop....rinse....repeat

替代验证:

If instr(currentUrl, "http") > 0 Then   'test
    'call the sub and extract value
End If

n = n + 1 'increment....loop....rinse....repeat

由于您已经有了i 的循环变量,因此根本不需要n。特别是考虑到以相同索引填充输出数组。


当你有Dim ie As时,ie 已经什么都不是了.....你想在一开始就实例化对象

Set ie = CreateObject("InternetExplorer.Application")

然后在整个循环中使用该实例。您已经在抓取子签名中包含ie,因此预计您将传递相同的实例:

Public Sub MM_description(currentValue As String, n As Long, firstRow As Long, ie As Object)

在签名中添加ByRefByVal

Public Sub MM_description(ByVal currentValue As String, ByVal n As Long, ByVal firstRow As Long, ByVal ie As Object)

在调用 sub 时删除多余的 Call 关键字并删除 () 因为这是一个带参数的 sub

Call MM_description(currentValue, n, firstRow, ie)  >  MM_description currentValue, n, firstRow, ie

当您将ie 传递给子MM_description 时,您不想遵循它并在被调用的子中实例化一个新实例。所以,删除

Set ie = Nothing
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False

从内部MM_description

在被调用的子里面:

中删除()
ie.Navigate2 (currentUrl)

所以

ie.Navigate2 currentUrl

并使用适当的页面加载等待。所以替换:

Do While ie.Busy
    Application.Wait DateAdd("s", 1, Now)
Loop

while .busy or .readystate <> 4:wend

删除未使用的变量,例如Dim html As HTMLDocument,并声明所有其他使用的,例如Dim mes As String。将Option Explicit 放在模块顶部以检查变量拼写和声明的一致性。


现在,我实际上会将这个子 MM_description 转换为一个函数,该函数返回抓取的字符串值或 "Not Found",并在调用该函数的同一循环中填充输出数组。

如果现在这是一个函数,签名需要指定返回类型,对函数的调用需要赋值,() 在评估时返回。

output(i) = MM_description(currentUrl, n, firstRow, ie)

最后,将output 数组一次性写入您想要输出值的任何范围。

Worksheets("Input").Range("F1").Resize(UBound(output), 1) = Application.Transpose(output)

上述许多变化会导致如下结构:

Option Explicit

Public Sub LooperForMMDescription()

    Dim currentUrl As String, i As Long
    Dim ie As Object, ws As Worksheet

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set table = ws.ListObjects("Table6")

    Dim arr(), table As ListObject, output()

    arr = Application.Transpose(table.ListColumns(1).DataBodyRange.Value)

    ReDim output(1 To UBound(arr))

    Set ie = CreateObject("InternetExplorer.Application")

    If IsEmpty(arr) Then Exit Sub

    ie.Visible = True

    For i = LBound(arr) To UBound(arr)
        currentUrl = arr(i)
        If InStr(currentUrl, "http") > 0 Then    'test
            'call the sub and extract value
            output(i) = MM_description(currentUrl, i, ie)
        End If
    Next i
    ie.Quit
    ThisWorkbook.Worksheets("Input").Range("F1").Resize(UBound(output), 1) = Application.Transpose(output)
End Sub

Public Function MM_description(ByVal currentUrl As String, ByVal i As Long, ByVal ie As Object) As String

    Dim codeLine As String, startPos As Long, endPos As Long, mes As String

    With ie
        .Navigate2 currentUrl

        While .Busy Or .readyState < 4: DoEvents: Wend

        mes = .document.body.innerHTML
        startPos = InStr(mes, "Description") + 61
        endPos = InStr(mes, "Address")

        If startPos = 0 Then
            MM_description = "Not Found"
        Else
            codeLine = Mid$(mes, startPos, endPos - startPos - 229)
            MM_description = codeLine
        End If
    End With
End Function

【讨论】:

  • 非常感谢。你能举两个例子来说明table6的内容吗? .. 顺便说一句,endPost As Long 应该是 endPos As Long
  • 我们需要 OP 来提供这个。在我的例子中,我在 Sheet1 中设置了一个名为 Table6 的测试表,并且在该表的第 1 列中我有 url。
  • @YasserKhalil 抱歉.... 刚刚看到您的最后一条评论.... 非常感谢并且发现了!
  • Wauv,这太棒了@QHarr! “Table6”:是一个单列范围,它包含 url。每个单元格中的一个 url 来自 BL7:BL356 关于“如果为空”命令。有些单元格是空的,但我需要循环继续,因为在空白单元格之后会有包含 url 的单元格。还有@YasserKhalil,感谢您注意到 endPost。我在使用 Option explicit 时发现
  • 那么最后的重写应该可以工作。它基于 Table6 是一个实际的 excel 表,即 ListObject。您的表格是实际的 Excel 表格吗?
猜你喜欢
  • 1970-01-01
  • 2023-01-02
  • 1970-01-01
  • 2019-12-17
  • 2015-09-17
  • 1970-01-01
  • 1970-01-01
  • 1970-01-01
  • 1970-01-01
相关资源
最近更新 更多