Do While Loop Is Stuck

[ajax1231]

Hi,
I have been working on putting together a web query with a loop to wait for the URL to load completely. I have gotten this to work, but I am unable to get the loop to end once this happens and to then complete the query. Any suggestions?

Sub Data()
Dim r As Long
Dim QT As QueryTable
Dim URL As String
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True


With Worksheets("Company Data")
For r = 2 To .Range("C" & .Rows.Count).End(xlUp).Row
URL = http://financials.morningstar.com/ratios/r.html?t=" & .Range("C" & r).Value & "&region=usa&culture=en-US"
IE.navigate URL
Do While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE
DoEvents
Loop
With Sheets("Company").QueryTables.Add(Connection:="URL;" & URL, Destination:=Sheets("Company").Range( _
"$A$1"))
.Name = "company_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next r
End With
End Sub

 

[rlv01]

Maybe something like this?

    Dim TimeOut As Double
    TimeOut = Timer
    Do While IE.busy Or IE.READYSTATE <> 4
        DoEvents
        If Timer - TimeOut > 60 Then '60 second timeout
            MsgBox "Early Exit. Problem getting data from website"
            Exit Do
        End If
    Loop

 

[ajax1231]

Thank you, that worked for ending my loop once the URL was fully loaded and completing the query.