Скребок макросов Замораживание после пары с парами

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 
       Set doc = IE.document 


       Dim dd As String 

        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 вопроса. Первое (и, вероятно, не связанное с проблемой, поскольку вы не упоминаете ошибку времени выполнения), заключается в том, что вы освобождаете объект IE внутри своего блока With IE. Удалить эту строку:

Set IE = Nothing 

Второй выпуск (и более вероятно, причиной откосе), является то, что вы никогда не проверить значение rngLink перед передачей его в .Navigate. Если rngLink оценивает vbNullString, объект IE никогда не изменит .readyState с READYSTATE_UNINITIALIZED, поэтому цикл ожидания никогда не выйдет. Я бы добавил простой тест:

If rngLink <> vbNullString Then 
    .navigate rngLink