In a for loop, I am opening a new instance of internet explorer, navigating to the new page number, getting data from html, then closing internet explorer. I am attempting to do this for 51 pages. It seems the problem is in the
Do While IEObject.Busy = True Or IEObject.readyState <> READYSTATE_COMPLETE
Just having DoEvents in that loop, it will go open and close each page as expected, but will not go into the rest of the code that copies the data
Application.Wait TimeValue("00:00:01") will go to each page and copy the html data, but requires me to manually hit the escape button after each page of internet explorer is loaded before it opens the next page.
Dim j As Integer
For j = 1 To 51
Dim IEObject As InternetExplorer
Set IEObject = New InternetExplorer
Dim urlstring As String
Dim pagestring As String
IEObject.Visible = True
pagestring = Str(j)
urlstring = "url.url" + pagestring
IEObject.navigate Url:=urlstring
Do While IEObject.Busy = True Or IEObject.readyState <> READYSTATE_COMPLETE
'DoEvents
Application.Wait TimeValue("00:00:01")
Loop
Dim IEDocument As HTMLDocument
Set IEDocument = IEObject.document
Dim OrddetClassName As IHTMLElementCollection
Set OrddetClassName = IEDocument.getElementsByClassName("cell-body")
Dim numoforddetclass As Integer
numoforddetclass = OrddetClassName.Length
Dim a As Integer
For a = 0 To numoforddetclass - 1
Dim OrddetNameCol As IHTMLElement
Set OrddetNameCol = OrddetClassName.Item(a)
If Not OrddetNameCol Is Nothing Then
Dim ordintxt As String
ordintxt = OrddetNameCol.innertext
Debug.Print ordintxt
End If
Next a
'more code that copies info spreadsheet for each page number
IEObject.Quit
Set IEObject = Nothing
Next j
Related
Good day - This is a follow to my previous post, but I feel since it was aswered I cant get further updates to it, so I created a new post to a different issue.
I am reading the list of cars from Craigslist Miami using VBA. The code is working fine with printing the links for each vehicle and price. The only issue when I select a different city for instance, Los Angeles, the URL sysntax changes and I am not sure how to read the class name. Code below works fine for Miami link (in the code), but does not work for this link:
https://losangeles.craigslist.org/search/cta#search=1~list~1~0
Sub newandoptimized()
Dim link As HTMLLinkElement
Dim blog As HTMLLinkElement
Dim price As HTMLLinkElement
Dim IE As Object
Dim html As HTMLDocument
Dim URL As String
Dim URLParameter As String
Dim page As Long, counter As Long
'Dim http As Object
Dim links As Object
Dim blogpost As Object
Dim priceonly As Object
Dim StartCell As Range
Dim increment As Integer
Dim htmlele1 As HTMLLinkElement
Dim ss As Integer
Dim ee As Integer
' This is the first cell that a blog post hyperlink is created in
Set StartCell = Range("A1")
URL = "https://miami.craigslist.org/search/cta"
Set IE = CreateObject("InternetExplorer.Application")
Application.ScreenUpdating = True
' CHnage this to False if you want to hide IE
IE.Visible = True
counter = 0
page = 0
'Set the number of pages of the website to go through in the browser
For page = 0 To 480 Step 120 'increment by 120 - total 4 pages
' Debug.Print page
If page >= 0 Then URLParameter = "?s=" & page
IE.navigate URL & URLParameter
'Wait for the browser to load the page
Do Until IE.readyState = 4
DoEvents
Loop
Set html = IE.document
Set links = html.getElementsByTagName("h3")
Index = 0
For Each link In links
If InStr(LCase(link.outerHTML), "result-heading") Then
Set blogpost = link.getElementsByTagName("a")
Set priceonly = link.getElementsByClassName("result-price")
Set Results = html.getElementsByClassName("result-row")
For Each blog In blogpost
StartCell.Offset(counter, 0).Hyperlinks.Add _
Anchor:=StartCell.Offset(counter, 0), Address:=blog, _
TextToDisplay:=link.innerText
StartCell.Offset(counter, 1).Value = Results(Index).getElementsByTagName("span")(0).innerText
Index = Index + 1
Next blog
counter = counter + 1
End If
Next link
Next page
IE.Quit
Set IE = Nothing
Columns("B:B").Select
Selection.NumberFormat = "$#,##0.00"
Columns("D:D").Select
Selection.NumberFormat = "m/d/yyyy;#"
End Sub
Recently our office upgraded to new laptops. Luckily in changing over from Windows 7 to 10 and from desktop to Laptops we did not experience any issues with running this macro other than needing to enable popups on Pilotdelivers.com. For a few weeks now we've run this macro on two different laptops and everything has gone smoothly.
Today, on one of the laptops the macro is no longer working correctly, but on the other it's fine. I checked to make sure popups were enabled and that both computers are running from the same excel worksheet on our network. I restarted the computer twice and ran the macro with no other applications open. Laptops are the same model, installed at the same time. Identical software installations and updates. The laptop that is having trouble is used by my less computer savvy co worker and the laptop that's working is mine. So it's possible that there's some setting he changed that he shouldn't have, but I'm not sure what to check.
It seems like it's skipping the portion of code that clicks a link to open a new tab.
What the macro is supposed to do:
copy the tracking number on the worksheet
open IE
insert the tracking number into the text box
click track
wait for the new page to load
click the tracking number link
wait for the new tab to load
close the first tab
check to see if the most recent update is DELIVERED
if yes it switches back to excel and inputs DELIVERED and the
delivery date, if not it looks at the most recent update and adds
that line to the worksheet.
What seems like the macro is doing:
copy the tracking number on the worksheet
open IE
insert the tracking number into the text box
click track
wait for the new page to load
seems to skip clicking on the tracking number link
wait for the current page to load (which is already loaded)
when looking for the latest update it grabs the tracking number
instead (since it's not the expected page)
check to see if it's marked DELIVERED
10.if yes it switches back to excel and inputs DELIVERED and the
delivery date, if not it looks at the most recent update and adds
that line to the worksheet
It seems like it skips some or all of this section of code:
Dim ieDOC As HTMLDocument
Set ieDOC = ie.document
Set htmlColl = ieDOC.getElementsByTagName("a")
For Each htmlInput In htmlColl
If htmlInput.ID = "clickElement" Then
htmlInput.Click
Exit For
End If
Next htmlInput
ie.Quit
Set shellWins = New ShellWindows
If shellWins.Count > 0 Then
Set ie2 = shellWins.Item(1)
End If
Full code below:
Sub PilotTracking()
Dim ProURL As String
Dim ie As Object
Dim ie2 As Object
Dim RowCount As Integer
Dim i As Integer
Dim html_Document As HTMLDocument
Dim htmlColl As MSHTML.IHTMLElementCollection
Dim htmlInput As MSHTML.HTMLInputElement
Dim shellWins As ShellWindows
Dim htmlColl2 As MSHTML.IHTMLElementCollection
Dim htmlInput2 As MSHTML.HTMLInputElement
Dim marker As Integer
RowCount = 0
ProURL = "http://www.pilotdelivers.com/"
Do While Not ActiveCell.Offset(RowCount, -5).Value = ""
Set ie = CreateObject("InternetExplorer.application")
With ie
.Visible = True
.navigate ProURL
Do Until Not ie.Busy And ie.readyState = 4: DoEvents: Loop
End With
Set Doc = ie.document 'works don't delete
Doc.getElementById("tbShipNum").innerHTML = ActiveCell.Offset(RowCount, -5).Value 'works don't delete
Doc.getElementById("btnTrack").Click 'works don't delete
Do Until Not ie.Busy And ie.readyState = 4: DoEvents: Loop
i = 0
Do While i < 4
WaitHalfSec
i = i + 1
Loop
Do Until Not ie.Busy And ie.readyState = 4: DoEvents: Loop
Dim ieDOC As HTMLDocument
Set ieDOC = ie.document
Set htmlColl = ieDOC.getElementsByTagName("a")
For Each htmlInput In htmlColl
If htmlInput.ID = "clickElement" Then
htmlInput.Click
Exit For
End If
Next htmlInput
ie.Quit
Set shellWins = New ShellWindows
If shellWins.Count > 0 Then
Set ie2 = shellWins.Item(1)
End If
i = 0
Do While i < 8
WaitHalfSec
i = i + 1
Loop
Do Until Not ie2.Busy And ie2.readyState = 4: DoEvents: Loop
Set htmlColl2 = ie2.document.getElementsByTagName("td")
For Each htmlInput2 In htmlColl2
If htmlInput2.className = "dxgv" Then
If ActiveCell.Offset(RowCount).Value = "" Then
ActiveCell.Offset(RowCount).Value = htmlInput2.innerText
Else
If ActiveCell.Offset(RowCount).Value <> "DELIVERED" Then
ActiveCell.Offset(RowCount, -2).Value = ""
Else
ActiveCell.Offset(RowCount, -2).Value = htmlInput2.innerText
End If
Exit For
End If
End If
Next htmlInput2
ie2.Quit
Set shellWins = Nothing
Set ie = Nothing
Set ie2 = Nothing
RowCount = RowCount + 1
Loop
Set shellWins = Nothing
Set ie = Nothing
Set ie2 = Nothing
End Sub
Sub WaitHalfSec()
Dim t As Single
t = Timer + 1 / 2
Do Until t < Timer: DoEvents: Loop
End Sub
Instead of this:
Set htmlColl = ieDOC.getElementsByTagName("a")
For Each htmlInput In htmlColl
If htmlInput.ID = "clickElement" Then
htmlInput.Click
Exit For
End If
Next htmlInput
You should be able to just do this:
ieDOC.getElementById("clickElement").Click
Id is supposed to be unique within a given page. I see you've used getElementById elsewhere, so was there some reason it's not used here?
I'd guess maybe the problem is this:
ie.Quit
so try commenting that out. Something to do perhaps with where new pages load (new window vs new tab?)
If you're having problems grabbing the correct IE document, then try something like:
Function GetIE(sLocation As String) As Object
Dim objShell As Object, objShellWindows As Object, o As Object
Dim sURL As String
Dim retVal As Object
Set retVal = Nothing
Set objShell = CreateObject("Shell.Application")
Set objShellWindows = objShell.Windows
For Each o In objShellWindows
sURL = ""
On Error Resume Next
'check the URL and if it's the one you want then
' assign it to the return value and exit the loop
sURL = o.document.Location
On Error GoTo 0
If sURL Like sLocation & "*" Then
Set retVal = o
Exit For
End If
Next o
Set GetIE = retVal
End Function
This function will return an IE window which matches the provided URL (i.e. the first on whose URL begins with the passed sLocation string)
I am trying to extract table from an internal website to excel by giving some input parameters. Everything works until it refreshes the website data with my inputs. The part I get the run-time error 438 is marked (For r = 1 To elemCollection.Rows.Length - 1). I also tried to load the data from website to excel using web query and the table wasn't showing up on my excel spreadsheet. "It gives the following error-This page might not function correctly because either your browser does not support scripts or active scripting is disabled. Your browser does not support scripts or has been configured not to allow scripts. The report viewer web control http handler has not been registered in the application's web config file."
Wondering if this has anything to do with permissions.
VBA code below:
Option Explicit
Sub Macro1()
Dim IE As Object, obj As Object
Dim StartDate As Object
Dim EndDate As Object
Dim myState As String
Dim r As Integer, c As Integer, t As Integer
Dim elemCollection As Object, curHTMLRow As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim objCollection As Object
Dim objElement As Object
Dim i As Long
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.navigate ("http://internalwebsite_SSRSReport")
' we ensure that the web page downloads completely before we fill the form automatically
While IE.ReadyState <> 4: DoEvents: Wend
IE.Document.All.Item("ctl31_ctl03_txtValue").InnerText = Format("7/1/2016", "m/d/yyyy")
IE.Document.All.Item("ctl31_ctl05_txtValue").InnerText = Format("7/31/2016", "m/d/yyyy")
Wait 2
IE.Document.getElementsByName("ctl31_ctl04_divDropDown").Item.Click
Wait 2
' accessing the button
IE.Document.getElementsByName("ctl31_ctl04_ctl00").Item.Click
Wait 2
' again ensuring that the web page loads completely before we start scraping data
While IE.busy: DoEvents: Wend
Wait 2
'Clearing any unnecessary or old data in Sheet1
ThisWorkbook.Sheets("Sheet1").Activate
Range("A1:K500").ClearContents
Set elemCollection = IE.Document.getelementbyId("ctl31_ctl09_ReportArea")
'error here
For r = 1 To elemCollection.Rows.Length - 1
Set curHTMLRow = elemCollection.Rows(r)
For c = 0 To curHTMLRow.Cells.Length - 1
Cells(r + 1, c + 1) = curHTMLRow.Cells(c).InnerText
Next
Next
' cleaning up memory
IE.Quit
Set IE = Nothing
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
Below is some code that should be able to grab the data from the HTML table from the SSRS report and extract it to Excel.
Basically the code will iterate through all the TRs and TDs in the Table Element, and output the InnerText to Excel. If you are moving a lot of data over, please consider writing to an array, then doing the write all at once by setting to an equally sized range object.
I also cleaned up the code, mostly removing variables that were not referenced and reduced some of the lines by combining some statements together
Option Explicit
Public Sub GetSSRSData()
On Error GoTo errhand:
Application.ScreenUpdating = False
Dim IE As Object: Set IE = CreateObject("InternetExplorer.Application")
Dim TR_Elements As Object
Dim TR As Object ' Table Row
Dim TD_Elements As Object
Dim TD As Object ' Table Data
Dim RowNumb As Integer
Dim Columns As Integer
Dim ColumnNumb As Integer
With IE
.Visible = True
.Navigate ("http://internalwebsite_SSRSReport")
While .ReadyState <> 4: DoEvents: Wend ' Wait for page load
'Fill the form out with dates
.Document.All.Item("ctl31_ctl03_txtValue").InnerText = Format("7/1/2016", "m/d/yyyy")
.Document.All.Item("ctl31_ctl05_txtValue").InnerText = Format("7/31/2016", "m/d/yyyy")
Wait 2
'Click the DropDown
.Document.getElementsByName("ctl31_ctl04_divDropDown").Item.Click
Wait 2
' Click the other button
.Document.getElementsByName("ctl31_ctl04_ctl00").Item.Click
End With
Wait 2
While IE.busy: DoEvents: Wend ' Wait for page load
Wait 2
'Clearing any unnecessary or old data in Sheet1
Sheets("Sheet1").Range("A1:K500").ClearContents
Set TR_Elements = IE.Document.getelementbyId("ctl31_ctl09_ReportArea").getElementsByTagName("tr")
RowNumb = 1
ColumnNumb = 1
'Tables usually consists of TR (Table Rows), and -
'TD (Table Data)
For Each TR In TR_Elements
Set TD_Elements = TR.getElementsByTagName("td")
ColumnNumb = 1
For Each TD In TD_Elements
'Consider using an array to save the values to memory if there is going
'to be a lot of data to be moved over
ActiveSheet.Cells(RowNumb, ColumnNumb).Value = TD.InnerText
ColumnNumb = ColumnNumb + 1
Next
RowNumb = RowNumb + 1
Next
' cleaning up memory
IE.Quit
Set IE = Nothing
Set TD_Elements = Nothing
Set TR_Elements = Nothing
Set TD = Nothing
Set TR = Nothing
Application.ScreenUpdating = True
errhand:
Application.ScreenUpdating = True
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
Thanks in advance for the help. I'm running Windows 8.1, I have the latest IE / Chrome browsers, and the latest Excel. I'm trying to write an Excel Macro that pulls data from StackOverflow (https://stackoverflow.com/tags). Specifically, I'm trying to pull the date (that the macro is run), the tag names, the # of tags, and the brief description of what the tag is. I have it working for the first page of the table, but not for the rest (there are 1132 pages at the moment). Right now, it overwrites the data everytime I run the macro, and I'm not sure how to make it look for the next empty cell before running.. Lastly, I'm trying to make it run automatically once per week.
I'd much appreciate any help here. Problems are:
Pulling data from the web table beyond the first page
Making it scrape data to the next empty row rather than overwriting
Making the Macro run automatically once per week
Code (so far) is below. Thanks!
Enum READYSTATE
READYSTATE_UNINITIALIZED = 0
READYSTATE_LOADING = 1
READYSTATE_LOADED = 2
READYSTATE_INTERACTIVE = 3
READYSTATE_COMPLETE = 4
End Enum
Sub ImportStackOverflowData()
'to refer to the running copy of Internet Explorer
Dim ie As InternetExplorer
'to refer to the HTML document returned
Dim html As HTMLDocument
'open Internet Explorer in memory, and go to website
Set ie = New InternetExplorer
ie.Visible = False
ie.navigate "http://stackoverflow.com/tags"
'Wait until IE is done loading page
Do While ie.READYSTATE <> READYSTATE_COMPLETE
Application.StatusBar = "Trying to go to StackOverflow ..."
DoEvents
Loop
'show text of HTML document returned
Set html = ie.document
'close down IE and reset status bar
Set ie = Nothing
Application.StatusBar = ""
'clear old data out and put titles in
'Cells.Clear
'put heading across the top of row 3
Range("A3").Value = "Date Pulled"
Range("B3").Value = "Keyword"
Range("C3").Value = "# Of Tags"
'Range("C3").Value = "Asked This Week"
Range("D3").Value = "Description"
Dim TagList As IHTMLElement
Dim Tags As IHTMLElementCollection
Dim Tag As IHTMLElement
Dim RowNumber As Long
Dim TagFields As IHTMLElementCollection
Dim TagField As IHTMLElement
Dim Keyword As String
Dim NumberOfTags As String
'Dim AskedThisWeek As String
Dim TagDescription As String
'Dim QuestionFieldLinks As IHTMLElementCollection
Dim TodaysDate As Date
Set TagList = html.getElementById("tags-browser")
Set Tags = html.getElementsByClassName("tag-cell")
RowNumber = 4
For Each Tag In Tags
'if this is the tag containing the details, process it
If Tag.className = "tag-cell" Then
'get a list of all of the parts of this question,
'and loop over them
Set TagFields = Tag.all
For Each TagField In TagFields
'if this is the keyword, store it
If TagField.className = "post-tag" Then
'store the text value
Keyword = TagField.innerText
Cells(RowNumber, 2).Value = TagField.innerText
End If
If TagField.className = "item-multiplier-count" Then
'store the integer for number of tags
NumberOfTags = TagField.innerText
'NumberOfTags = Replace(NumberOfTags, "x", "")
Cells(RowNumber, 3).Value = Trim(NumberOfTags)
End If
If TagField.className = "excerpt" Then
Description = TagField.innerText
Cells(RowNumber, 4).Value = TagField.innerText
End If
TodaysDate = Format(Now, "MM/dd/yy")
Cells(RowNumber, 1).Value = TodaysDate
Next TagField
'go on to next row of worksheet
RowNumber = RowNumber + 1
End If
Next
Set html = Nothing
'do some final formatting
Range("A3").CurrentRegion.WrapText = False
Range("A3").CurrentRegion.EntireColumn.AutoFit
Range("A1:C1").EntireColumn.HorizontalAlignment = xlCenter
Range("A1:D1").Merge
Range("A1").Value = "StackOverflow Tag Trends"
Range("A1").Font.Bold = True
Application.StatusBar = ""
MsgBox "Done!"
End Sub
There's no need to scrape Stack Overflow when they make the underlying data available to you through things like the Data Explorer. Using this query in the Data Explorer should get you the results you need:
select t.TagName, t.Count, p.Body
from Tags t inner join Posts p
on t.ExcerptPostId = p.Id
order by t.count desc;
The permalink to that query is here and the "Download CSV" option which appears after the query runs is probably the easiest way to get the data into Excel. If you wanted to automate that part of things, the direct link to the CSV download of results is here
You can improve this to parse out exact elements but it loops all the pages and grabs all the tag info (everything next to a tag)
Option Explicit
Public Sub ImportStackOverflowData()
Dim ie As New InternetExplorer, html As HTMLDocument
Application.ScreenUpdating = False
With ie
.Visible = True
.navigate "https://stackoverflow.com/tags"
While .Busy Or .READYSTATE < 4: DoEvents: Wend
Set html = .document
Dim numPages As Long, i As Long, info As Object, item As Object, counter As Long
numPages = html.querySelector(".page-numbers.dots ~ a").innerText
For i = 1 To 2 ' numPages ''<==1 to 2 for testing; use to numPages
DoEvents
Set info = html.getElementById("tags_list")
For Each item In info.getElementsByClassName("grid-layout--cell tag-cell")
counter = counter + 1
Cells(counter, 1) = item.innerText
Next item
html.querySelector(".page-numbers.next").Click
While .Busy Or .READYSTATE < 4: DoEvents: Wend
Set html = .document
Next i
Application.ScreenUpdating = True
.Quit '<== Remember to quit application
End With
End Sub
I'm not making use of the DOM, but I find it very easy to get around just searching between known tags. If ever the expressions you are looking for are too common just tweak the code a bit so that it looks for a string after a string).
An example:
Public Sub ZipLookUp()
Dim URL As String, xmlHTTP As Object, html As Object, htmlResponse As String
Dim SStr As String, EStr As String, EndS As Integer, StartS As Integer
Dim Zip4Digit As String
URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=1&companyName=&address1=1642+Harmon+Street&address2=&city=Berkeley&state=CA&urbanCode=&postalCode=&zip=94703"
Set xmlHTTP = CreateObject("MSXML2.XMLHTTP")
xmlHTTP.Open "GET", URL, False
On Error GoTo NoConnect
xmlHTTP.send
On Error GoTo 0
Set html = CreateObject("htmlfile")
htmlResponse = xmlHTTP.ResponseText
If htmlResponse = Null Then
MsgBox ("Aborted Run - HTML response was null")
Application.ScreenUpdating = True
GoTo End_Prog
End If
'Searching for a string within 2 strings
SStr = "<span class=""address1 range"">" ' first string
EStr = "</span><br />" ' second string
StartS = InStr(1, htmlResponse, SStr, vbTextCompare) + Len(SStr)
EndS = InStr(StartS, htmlResponse, EStr, vbTextCompare)
Zip4Digit = Left(Mid(htmlResponse, StartS, EndS - StartS), 4)
MsgBox Zip4Digit
GoTo End_Prog
NoConnect:
If Err = -2147467259 Or Err = -2146697211 Then MsgBox "Error - No Connection": GoTo End_Prog 'MsgBox Err & ": " & Error(Err)
End_Prog:
End Sub
I am trying to grab some football player data from a website to fill a privately used database. I've included the entire code below. This first section is a looper that calls the second function to fill a database. I've run this code in MSAccess to fill a database last summer and it worked great.
Now I am only getting a few teams to fill before the program gets hung up at
While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
I've searched countless websites regarding this error and tried changing this code by putting in sub function to wait a period of seconds or other work-arounds. None of those solve the issue. I've also tried running this on multiple computers.
The first computer made it through 3 teams (or three calls of the 2nd function). The second slower computer makes it through 5 teams. Both eventually hang. The 1st computer has Internet Explorer 10 and the second has IE8.
Sub Parse_NFL_RawSalaries()
Status ("Importing NFL Salary Information.")
Dim mydb As Database
Dim teamdata As DAO.Recordset
Dim i As Integer
Dim j As Double
Set mydb = CurrentDb()
Set teamdata = mydb.OpenRecordset("TEAM")
i = 1
With teamdata
Do Until .EOF
Call Parse_Team_RawSalaries(teamdata![RotoworldTeam])
.MoveNext
i = i + 1
j = i / 32
Status("Importing NFL Salary Information. " & Str(Round(j * 100, 0)) & "% done")
Loop
End With
teamdata.Close ' reset variables
Set teamdata = Nothing
Set mydb = Nothing
Status ("") 'resets the status bar
End Sub
Second function:
Function Parse_Team_RawSalaries(Team As String)
Dim mydb As Database
Dim rst As DAO.Recordset
Dim IE As InternetExplorer
Dim HTMLdoc As HTMLDocument
Dim TABLEelements As IHTMLElementCollection
Dim TRelements As IHTMLElementCollection
Dim TDelements As IHTMLElementCollection
Dim TABLEelement As Object
Dim TRelement As Object
Dim TDelement As HTMLTableCell
Dim c As Long
' open the table
Set mydb = CurrentDb()
Set rst = mydb.OpenRecordset("TempSalary")
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.navigate "http://www.rotoworld.com/teams/contracts/nfl/" & Team
While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
Set HTMLdoc = IE.Document
Set TABLEelements = HTMLdoc.getElementsByTagName("Table")
For Each TABLEelement In TABLEelements
If TABLEelement.id = "cp1_tblContracts" Then
Set TRelements = TABLEelement.getElementsByTagName("TR")
For Each TRelement In TRelements
If TRelement.className <> "columnnames" Then
rst.AddNew
rst![Team] = Team
c = 0
Set TDelements = TRelement.getElementsByTagName("TD")
For Each TDelement In TDelements
Select Case c
Case 0
rst![Player] = Trim(TDelement.innerText)
Case 1
rst![position] = Trim(TDelement.innerText)
Case 2
rst![ContractTerms] = Trim(TDelement.innerText)
End Select
c = c + 1
Next TDelement
rst.Update
End If
Next TRelement
End If
Next TABLEelement
' reset variables
rst.Close
Set rst = Nothing
Set mydb = Nothing
IE.Quit
End Function
In Parse_Team_RawSalaries, instead of using the InternetExplorer.Application object, how about using MSXML2.XMLHTTP60?
So, instead of this:
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
IE.navigate "http://www.rotoworld.com/teams/contracts/nfl/" & Team
While IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE: DoEvents: Wend
Set HTMLdoc = IE.Document
Maybe try using this (add a reference to "Microsoft XML 6.0" in VBA Editor first):
Dim IE As MSXML2.XMLHTTP60
Set IE = New MSXML2.XMLHTTP60
IE.Open "GET", "http://www.rotoworld.com/teams/contracts/nfl/" & Team, False
IE.send
While IE.ReadyState <> 4
DoEvents
Wend
Dim HTMLDoc As MSHTML.HTMLDocument
Dim HTMLBody As MSHTML.htmlBody
Set HTMLDoc = New MSHTML.HTMLDocument
Set HTMLBody = HTMLDoc.body
HTMLBody.innerHTML = IE.responseText
I've generally found that MSXML2.XMLHTTP60 (and WinHttp.WinHttpRequest, for that matter) generally perform better (faster and more reliable) than InternetExplorer.Application.
I've found this post very helpful when I encountered similiar problem. Here is my solution:
I used
Dim browser As SHDocVw.InternetExplorer
Set browser = New SHDocVw.InternetExplorer
and
cTime = Now + TimeValue("00:01:00")
Do Until (browser.readyState = 4 And Not browser.Busy)
If Now < cTime Then
DoEvents
Else
browser.Quit
Set browser = Nothing
MsgBox "Error"
Exit Sub
End If
Loop
Sometimes page is loaded but code stops on DoEvents and goes on and on and on. Using this code it goes on only for 1 minute and if browser is not ready it quits the browser and exits sub.
I know this is a old post but. I have had the same problem with my code for downloading web site pictures using Excel VBA automation. Some sites wont let you download a image file using a link without first opening the link in a browser. However my code was getting hung up sometimes with when the objBrowser.visible was set to false with the folowing code
Do Until (objBrowser.busy = False And objBrowser.readyState = 4)
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents 'browser.readyState = 4
Loop
the simple fix was to make the objBrowser.visible
I fixed it with
Dim Passes As Integer: Passes = 0
Do Until (objBrowser.busy = False And objBrowser.readyState = 4)
Passes = Passes + 1 'count loops
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
If Passes > 5 Then
'set size browser cannot set it smaller than 400
objBrowser.Width = 400 'set size
objBrowser.Height = 400
Label8.Caption = Passes 'display loop count
' position browser "you cannot move it off the screen" ready state wont change
objBrowser.Left = UserForm2.Left + UserForm2.Width
objBrowser.Top = UserForm2.Top + UserForm2.Height
objBrowser.Visible = True
DoEvents
objBrowser.Visible = False
End If
Loop
objBrowser only flashes for less than a second but it gets the job done!