vba - Excel VBA 无法加载 Internet Explorer

Question

我有一个本地网页列表(超过 9000 个)，我想用 Excel VBA 对其进行解析。 我使用 Office 2013 和 IE 11:

• Windows 7 Enterprise Pro x64、16 GB RAM、i7 - 处理器
• Windows 8.1 Enterprise x64、12 GB RAM、i7 处理器

两台机器上的问题是，在成功解析大约 70-80 个页面后，程序突然无法将下一个网页加载到 IE 中。可以这么说，它被“卡住”了(请参阅下面代码中的注释)。如果我重置程序，那么在再次“失败”后，它可以再次毫无问题地解析大约 70-80 个配置文件。

[编辑:抱歉，我错误地发布了错误的代码。这是更正后的 版本]

这是部分代码:

    <!-- language: lang-HTML -->
Sub ImportFromWebpage()

    'GLOBAL VARIABLES
    Dim html As HTMLDocument
    Dim CurrentRowPosition, ProfileNumber, TotalProfiles As Integer
    Dim TempProfileID As String
    Dim profileRange, posCounter, currentProfile As Range
        Set profileRange = Worksheets("List_of_Files").Range("B2:B20000")
        ProfileNumber = 519
        CurrentRowPosition = 520
        TotalProfiles = Application.WorksheetFunction.CountA(profileRange)
    'MsgBox "TotalProfiles = " & TotalProfiles



    'VARIABLES NEEDED FOR PARSING HERE
    'ELEMENTS
    Dim firstIHTMLElmt, secondIHTMLElmt, thirdIHTMLElmt As IHTMLElement
    Dim firstTempIHTMLElmt, secondTempIHTMLElmt, thirdTempIHTMLElmt, fourthTempIHTMLElmt, fiftTempIHTMLElmt As IHTMLElement
    'COLLECTIONS
    Dim firstIHTMLEColl, secondIHTMLEColl, thirdIHTMLEColl As IHTMLElementCollection
    Dim firstTempIHTMLEColl, secondTempIHTMLEColl, thirdTempIHTMLEColl, fourthTempIHTMLEColl, fifthTempIHTMLEColl As IHTMLElementCollection

    Dim ie As InternetExplorerMedium
    Set ie = New InternetExplorerMedium
    ie.Visible = False

    'FROM HERE LOOPING
    For startNumber = 1 To TotalProfiles

        Application.StatusBar = "Loading profile " & ProfileNumber & " from a total of " & TotalProfiles & " profiles"
        'Set currentProfile = Worksheets("List_of_Files").Range("J" & CurrentRowPosition) // OLD
        Set currentProfile = Worksheets("List_of_Files").Range("B" & CurrentRowPosition)
        ie.navigate currentProfile

        Application.StatusBar = "Loading profile: " & ProfileNumber & "; file location: " & currentProfile
            Do While ie.READYSTATE <> READYSTATE_COMPLETE
                DoEvents
            Loop

        Application.StatusBar = "Storing " & currentProfile & " information into HTMLElement"
        Set html = ie.document
        Set ie = Nothing

    [code, code, code, code ...]



    Application.Wait (Now + TimeValue("0:00:02"))

    Next startNumber

    Set html = Nothing
    ie.Quit
    Set ie = Nothing

    MsgBox "Done parsing all profiles!"

End Sub 

以下是 Windows 8.1 任务管理器加载失败后的屏幕截图:

有人知道为什么会发生这种情况吗？不仅在一台机器上，而且在两台机器上。

我对编程没有太多经验，更不用说 VBA 了，因此我们将不胜感激。

Answer 1

在我的案例中，这个解决方案被证明是一个很好的解决方案。不知道这是否是最好的解决方案，但它对我来说非常有用。

• 在循环之前放置 IE 声明 以启动 Internet Explorer 实例；这是将使用的唯一实例(链接将在此实例中刷新)
• 在循环内设置 html = Nothing
• 在循环之外设置 ie = Nothing，以便仅刷新链接而无需重新启动 IE
• ie.Quit 仅在解析所有 >9000 个网页后(因此在循环之外)

希望它可以帮助其他遇到同样问题的人。

Sub ImportFromWebpage()
'GLOBAL VARIABLES
Dim html As HTMLDocument
Dim CurrentRowPosition, ProfileNumber, TotalProfiles As Integer
Dim TempProfileID As String
Dim profileRange, posCounter, currentProfile As Range
    Set profileRange = Worksheets("List_of_Files").Range("B2:B20000")
    ProfileNumber = 1
    CurrentRowPosition = 2
    TotalProfiles = Application.WorksheetFunction.CountA(profileRange)
'MsgBox "TotalProfiles = " & TotalProfiles

Dim ie As InternetExplorerMedium
Set ie = New InternetExplorerMedium
ie.Visible = False

'FROM HERE LOOPING
For startNumber = 1 To TotalProfiles

    Application.StatusBar = "Loading profile " & ProfileNumber & " from a total of " & TotalProfiles & " profiles"
    'Set currentProfile = Worksheets("List_of_Files").Range("J" & CurrentRowPosition) // OLD
    Set currentProfile = Worksheets("List_of_Files").Range("B" & CurrentRowPosition)
    ie.navigate currentProfile

    Application.StatusBar = "Loading profile: " & ProfileNumber & "; file location: " & currentProfile
        Do While ie.READYSTATE <> READYSTATE_COMPLETE
            DoEvents
        Loop

    Application.StatusBar = "Storing " & currentProfile & " information into HTMLElement"
    Set html = ie.document

    [code, code, code, code ...]

    Set html = Nothing
    Application.Wait (Now + TimeValue("0:00:02"))

Next startNumber

  Set ie = Nothing
  ie.Quit
  MsgBox "Done parsing all profiles!"
End Sub