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的计算结果为.readyState，则IE对象永远不会从READYSTATE_UNINITIALIZED更改If rngLink <> vbNullString Then .navigate rngLink，因此您的等待循环将永远不会退出。我会添加一个简单的测试：

var SFTPServer = require("node-sftp-server");

var srv = new SFTPServer("private.ppk");
srv.listen(45);
console.warn("server listening on port 45");

srv.on("connect", function (auth)
{
    console.warn("authentication attempted");
    if (auth.method !== 'password' || auth.username !== "brady" || auth.password !== "test")
    {
        return auth.reject();
    }
    console.warn("We haven't *outhright* accepted yet...");
    var username = auth.username;
    var password = auth.password;

    return auth.accept(function (session)
    {
        console.warn("Okay, we've accepted, allegedly?");
    });
});

srv.on("end", function ()
{
    return console.warn("Example says user disconnected");
});

几次循环后刮刮宏观冻结

1 个答案: