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"，并在调用该函数的同一循环中填充输出数组。 / p>

如果这现在是一个函数，则签名需要指定一个返回类型，对该函数的调用需要一个赋值，并且()会在有求值的情况下返回。

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

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

1 个答案: