Scraping Macro Freezing after Just a Couple Loops
<p>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!</p>

<pre><code>    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" &amp; Rows)
    i = 2

    With IE
        .Visible = True

        For Each rngLink In rngLinks
            .navigate (rngLink)

            While .Busy Or .readyState &lt;&gt; 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" &amp; 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" &amp; Rows), Type:=xlFillDefault
    Range("C2:C" &amp; 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" &amp; Rows), Type:=xlFillDefault
    Range("D2:D" &amp; 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" &amp; Rows), Type:=xlFillDefault
    Range("E2:E" &amp; 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" &amp; 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" &amp; Rows
</code></pre>