几个循环后刮宏冻结

Question

我有一个抓取宏，以前工作得很好，现在只循环了几次（有时一次）就死机了。我已经做了我能想到的优化宏不占用太多CPU。我完全不明白为什么宏会像这样冻结。我的代码如下，任何提示或批评将不胜感激！

    Application.DisplayStatusBar = True
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Dim wb1 As Workbook
    Dim ws1 As Worksheet
    Dim Rows As Long, IE As InternetExplorer
    Dim i As Long
    Dim rngLinks As Range, rngLink As Range

    Sheet1.Cells.ClearContents
    Sheets("Landing Page").Select
    Range("E7").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues

    Sheets("Landing Page").Select
    Range("B5").Select
    Application.CutCopyMode = False
    Selection.Copy

    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Worksheets("Sheet1")
    Set IE = New InternetExplorer

    Rows = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    Set rngLinks = ws1.Range("A2:A" & Rows)
    i = 2

    With IE
        .Visible = True

        For Each rngLink In rngLinks
            .navigate (rngLink)

            While .Busy Or .readyState <> 4: DoEvents: Wend
            Application.Wait (Now() + TimeValue("00:00:004"))

            Dim doc As Object, dd As String
            Set doc = IE.document

            On Error GoTo Errorhandler:
            dd = doc.getElementsByClassName("price-display csTile-price")(0).innerText

            ws1.Range("B" & i).Value = dd

            i = i + 1

            Application.StatusBar = i

            dd = ""

            Set IE = Nothing
        Next rngLink
    End With

Errorhandler:

    dd = ""

    Resume Next

    Application.Calculation = xlCalculationAutomatic
    ws1.Activate
    Set rngLinks = Nothing

    'Strip out everything but total price

    Range("C2").Select
    ActiveCell.FormulaR1C1 = "=LEFT(RC[-1],FIND("" "",RC[-1])-0)"
    Range("C2").Select
    Selection.AutoFill Destination:=Range("C2:C" & Rows), Type:=xlFillDefault
    Range("C2:C" & Rows).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                           :=False, Transpose:=False

    'Apply OnlyNums formula to remove delimeters
    Range("D2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=OnlyNums(RC[-1])"
    Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D" & Rows), Type:=xlFillDefault
    Range("D2:D" & Rows).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                           :=False, Transpose:=False

    'Add decimal back in
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "=iferror(RC[-1]/100,"" "")"
    Range("E2").Select
    Selection.AutoFill Destination:=Range("E2:E" & Rows), Type:=xlFillDefault
    Range("E2:E" & Rows).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                           :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Style = "Currency"

    'Remove columns C and D
    Columns("C:D").Select
    Selection.Delete Shift:=xlToLeft

    'Add column headers to F and G
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "HTML Export (Raw)"

    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Price"

    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.DisplayPageBreaks = False

    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Collection Date"
    Rows2 = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
    Range("D2:D" & Rows2).Value = Date
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "Company Store Number"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "UPC"

    Sheets("Landing Page").Select
    Range("B8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Range("E2").PasteSpecial xlPasteValues

    Sheets("Landing Page").Select
    Range("E8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Range("A2").PasteSpecial xlPasteValues

    Sheets("Landing Page").Select
    Range("D8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Range("F2").PasteSpecial xlPasteValues

    ws1.Activate

    Application.Calculation = xlCalculationAutomatic

    Dim acc As New Access.Application

    acc.OpenCurrentDatabase "S:\Aditem\Pricing\Scraping\Database.accdb"
    acc.DoCmd.TransferSpreadsheet _
        TransferType:=acImport, _
        SpreadSheetType:=acSpreadsheetTypeExcel12, _
        TableName:="Company", _
        Filename:=Application.ActiveWorkbook.FullName, _
        HasFieldNames:=True, _
        Range:="Sheet1$C1:F" & Rows

Answer 1

2 个问题。首先（并且可能与问题无关，因为您没有提到运行时间错误）是您在 With IE 块中释放 IE 对象。删除此行：

Set IE = Nothing

第二个问题（更可能是挂起的原因）是您在将 rngLink 传递给 .Navigate 之前从未测试过它的值。如果 rngLink 的计算结果为 vbNullString，IE 对象永远不会从 READYSTATE_UNINITIALIZED 更改 .readyState，因此您的等待循环永远不会退出。我会添加一个简单的测试：

If rngLink <> vbNullString Then
    .navigate rngLink

几个循环后刮宏冻结

Scraping Macro Freezing after Just a Couple Loops

macros

excel

vba

loops

screen-scraping