excel - 避免多次运行IE Web抓取时崩溃VBA

Question

当我多次刮取信息网站并将其插入单元格时，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次迭代，但随后返回错误

Answer 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)

因此，应该在循环中指定第二个维度，将2d数组读入变量中会比效率更高，而不是反复重复昂贵的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

考虑将局部变量重命名为更有用/更具描述性的值:将 currentValue更改为 currentUrl，因为这对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。特别是考虑到以相同的索引填充输出数组。

当您拥有 ie .....时， Dim ie As已经不算什么了。您想在开始时实例化该对象

Set ie = CreateObject("InternetExplorer.Application")

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

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

将 ByRef， ByVal添加到签名

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

调用子程序时删除多余的 Call关键字，并删除 ()，因为这是带有参数的子程序

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