只是一對夫婦循環後刮開宏凍結

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期。首先（並且可能與此問題無關，因爲您沒有提及運行時錯誤）是您正在釋放您的With IE塊內的IE對象。刪除這一行：

Set IE = Nothing 

第二個問題（和懸掛的更可能的原因），就是你從來沒有將它傳遞給.Navigate之前測試的rngLink值。如果rngLink的計算結果爲vbNullString，IE對象將永遠不會從READYSTATE_UNINITIALIZED更改.readyState，所以您的等待循環將永遠不會退出。我會添加一個簡單的測試：

If rngLink <> vbNullString Then 
    .navigate rngLink