Scraping Macro Freezing after Just a Couple Loops

Question

I have a scraping macro that used to work just fine, and is now freezing after just a couple loops (sometimes one). I've done what I can think of to optimize the macro to not take up too much CPU. I am completely confused as to why the macro would be freezing like this. My code is below, any tips or critiques would be much appreciated!

    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 issues. First (and likely not related to the issue since you don't mention a run-time error) is that you are releasing the IE object inside your With IE block. Remove this line:

Set IE = Nothing

The second issue (and more likely the cause of the hang), is that you never test the value of rngLink before passing it to .Navigate. If rngLink evaluates to vbNullString, the IE object will never change the .readyState from READYSTATE_UNINITIALIZED, so your wait loop will never exit. I'd add a simple test:

If rngLink <> vbNullString Then
    .navigate rngLink