This is the code I wrote I need it to loop when it copy and paste the table and then click the next button till there no more next button , the next button is a tagname "a" and it has a "href" that I used to click the hyper link
Any help would be appreciated thanks
Sub GetData()
'define variables
Dim i As SHDocVw.InternetExplorer
Set i = New InternetExplorer
i.Visible = True
Dim IE As Object, obj As Object
Dim r As Long, c As Long, t As Long
Dim elemCollection As Object
Dim eRow As Long
Dim HTMLDoc As MSHTML.HTMLDocument
Dim HTMLInput As MSHTML.IHTMLElement
Dim HTMLAs As MSHTML.IHTMLElementCollection
Dim HTMLA As MSHTML.IHTMLElement
url_name = Sheet2.Range("e4")
If url_name = "" Then Exit Sub
i.Visible = True
i.navigate (url_name)
Do While i.readyState <> READYSTATE_COMPLETE
Loop
'we ensure that the web page is downloaded completely
ThisWorkbook.Sheets("Sheet1").Range("a2:ai1000").ClearContents
Set elemCollection = i.document.getElementsByTagName("TABLE")
For t = 0 To (elemCollection.Length - 1)
For r = 0 To (elemCollection(t).Rows.Length - 1)
eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For c = 0 To (elemCollection(t).Rows(r).Cells.Length - 1)
ThisWorkbook.Worksheets(1).Cells(eRow, c + 1) = elemCollection(t).Rows(r).Cells(c).innerText
Next c
Next r
Next t
Range("a1:ai1000").Columns.AutoFit
'Clean up Memory
Set IE = Nothing
Set HTMLDoc = i.document
Set HTMLAs = HTMLDoc.getElementsByTagName("a")
For Each HTMLA In HTMLAs
'Debug.Print HTMLA.getAttribute("classname"), HTMLA.getAttribute("href")
If HTMLA.getAttribute("classname") = "button2 next" And HTMLA.getAttribute("href") = "https://stathead.com/football/pgl_finder.cgi?request=1&game_num_max=99&week_num_max=99&order_by=all_td&match=game&season_start=1&year_max=2020&qb_gwd=0&qb_comeback=0&season_end=-1&game_type=R&age_max=99&year_min=2020&offset=100" Then
HTMLA.Click
Exit For
End If
Next
End Sub
Related
Sub Web_Table_Option_Two()
Dim HTMLDoc As New HTMLDocument
Dim objTable As Object
Dim lRow As Long
Dim lngTable As Long
Dim lngRow As Long
Dim lngCol As Long
Dim ActRw As Long
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
objIE.navigate "https://finviz.com/screener.ashx?v=152"
Do Until objIE.readyState = 4 And Not objIE.Busy
DoEvents
Loop
Application.Wait (Now + TimeValue("0:00:03")) 'wait for java script to load
HTMLDoc.body.innerHTML = objIE.document.body.innerHTML
With HTMLDoc.body
Set objTable = .getElementsByTagName("table")
For lngTable = 0 To objTable.Length - 1
For lngRow = 0 To objTable(lngTable).Rows.Length - 1
For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
Next lngCol
Next lngRow
ActRw = ActRw + objTable(lngTable).Rows.Length + 1
Next lngTable
End With
objIE.Quit
End Sub
`
With the code above I am trying to get the Stock Screener data from the website in the code but the table isn't labeled in HTML code so I am not sure how I am supposed to grab this info. Currently it is grabbing everything on the screen.
For just the bottom table info you can use the following and target the tbody tag collection, and the required index within, to avoid all the unwanted fluff that comes with table selection.
I would use XMLHTTP request as faster. The appropriate index changes between the two methods.
XMLHTTP request:
Option Explicit
Public Sub GetTable()
Dim sResponse As String, html As HTMLDocument, hTable As Object
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://finviz.com/screener.ashx?v=152", False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
sResponse = StrConv(.responseBody, vbUnicode)
End With
With html
.body.innerHTML = sResponse
Set hTable = .getElementsByTagName("tbody")(9)
WriteTable hTable, 1, ThisWorkbook.Worksheets("Sheet1")
End With
End Sub
Public Sub WriteTable(ByVal hTable As Object, Optional ByVal startRow As Long = 1, Optional ByVal ws As Worksheet)
If ws Is Nothing Then Set ws = ActiveSheet
Dim tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long
r = startRow
With ws
Set tRow = hTable.getElementsByTagName("tr")
For Each tr In tRow
r = r + 1: c = 1
Set tCell = tr.getElementsByTagName("td")
For Each td In tCell
.Cells(r, c).Value = td.innerText
c = c + 1
Next td
Next tr
End With
End Sub
Internet Explorer (using WriteTable sub from above):
Option Explicit
Public Sub GetInfo()
Dim IE As New InternetExplorer, hTable As Object
With IE
.Visible = True
.navigate "https://finviz.com/screener.ashx?v=152"
While .Busy Or .readyState < 4: DoEvents: Wend
Set hTable = .document.getElementsByTagName("tbody")(13)
WriteTable hTable, 1, ThisWorkbook.Worksheets("Sheet1")
.Quit
End With
End Sub
Output:
References (VBE > Tools > References):
Microsoft Internet Controls
Microsoft HTML Object Library
I'm using the below Code to input Google's first images link in B1
for certain values in A1.
Public Sub Test()
Dim IE As InternetExplorer
Dim HTMLdoc As HTMLDocument
Dim imgElements As IHTMLElementCollection
Dim imgElement As HTMLImg
Dim aElement As HTMLAnchorElement
Dim N As Integer, I As Integer
Dim Url As String, Url2 As String
Dim LastRow As Long
Dim m, sImageSearchString
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To LastRow
Url = "http://www.google.co.in/search?q=" & Cells(I, 1) & "&source=lnms&tbm=isch&sa=X&rnd=1"
Set IE = New InternetExplorer
With IE
.Visible = False
.Navigate Url 'sWebSiteURL
Do Until .readyState = 4: DoEvents: Loop
'Do Until IE.document.readyState = "Complete": DoEvents: Loop
Set HTMLdoc = .document
Set imgElements = HTMLdoc.getElementsByTagName("IMG")
N = 1
For Each imgElement In imgElements
If InStr(imgElement.src, sImageSearchString) Then
If imgElement.ParentNode.nodeName = "A" Then
Set aElement = imgElement.ParentNode
Url2 = imgElement.src
N = N + 1
End If
End If
Next
Cells(I, 2) = Url2
IE.Quit
Set IE = Nothing
End With
Next
End Sub
however I'm receiving the below error, can you please advise?
I'm using Windows 10, Excel 365
In VBA Menu - Tools - References - tick MS Internet Controls.
Or
Using Late Binding
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
I am trying to extract the team names but i get the "Run time error 424 Object required" on this line
Set lists = html.getElementsByClassName("KambiBC-event-item__participants-container")
, if anyone could point me in the right direction it would be nice.
Sub useClassnames()
Dim lists As IHTMLElementCollection
Dim anchorElements As IHTMLElementCollection
Dim ulElement As HTMLUListElement
Dim liElement As HTMLLIElement
Dim row As Long
Dim ie As InternetExplorer
Set ie = New InternetExplorer
With ie.navigate "https://www.unibet.ro/betting#filter/all/all/all/all/in-play"
.Visible = True
Do While ie.readyState <> READYSTATE_COMPLETE
DoEvents
Loop
End With
Set lists = html.getElementsByClassName("KambiBC-event-item__participants-container")
row = 1
For Each ulElement In lists
For Each liElement In ulElement.getElementsByClassName("KambiBC-event-participants")
Set anchorElements = liElement.getElementsByClassName("KambiBC-event-participants__name")
If anchorElements.Length > 0 Then
Cells(row, 1) = anchorElements.Item(0).innerText
row = row + 1
End If
Next liElement
Next ulElement
End Sub
Error 424 is an Object Required Error. What is Html in Set lists = html.getElementsByClassName("KambiBC-event-item__participants-container")?
What you need is
Set lists = ie.document.getElementsByClassName("KambiBC-event-item__participants-container")
Code that I used
Sub useClassnames()
Dim lists As IHTMLElementCollection
Dim anchorElements As IHTMLElementCollection
Dim ulElement As HTMLUListElement
Dim liElement As HTMLLIElement
Dim row As Long
Dim ie As InternetExplorer
Set ie = New InternetExplorer
With ie
.navigate "https://www.unibet.ro/betting#filter/all/all/all/all/in-play"
.Visible = True
Do While ie.readyState <> READYSTATE_COMPLETE
DoEvents
Loop
End With
Set lists = ie.document.getElementsByClassName("KambiBC-event-item__participants-container")
row = 1
For Each ulElement In lists
For Each liElement In ulElement.getElementsByClassName("KambiBC-event-participants")
Set anchorElements = liElement.getElementsByClassName("KambiBC-event-participants__name")
If anchorElements.Length > 0 Then
Cells(row, 1) = anchorElements.Item(0).innerText
row = row + 1
End If
Next liElement
Next ulElement
End Sub
Screenshot
Anyone know how to get a macro (Excel VBA) to stop when there is no next button present (so it should scrape x pages until next button value is no longer present).
Any help? Loop Until e.Value <> "Next Results"
Sub Test()
Dim ie As Object
Dim i As Long
Dim strText As String
Dim doc As Object
Dim hTable As Object
Dim hBody As Object
Dim hTR As Object
Dim hTD As Object
Dim tb As Object
Dim bb As Object
Dim tr As Object
Dim td As Object
Dim y As Long, z As Long, wb As Excel.Workbook, ws As Excel.Worksheet
Set wb = Excel.ActiveWorkbook
Set ws = wb.ActiveSheet
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
y = 1 'Column A in Excel
z = 1 'Row 1 in Excel
variable = 0
Here:
ie.navigate "http://games.espn.com/ffl/tools/projections?&seasonTotals=true&seasonId=2016&slotCategoryId=0&startIndex=" & variable
Do While ie.Busy: DoEvents: Loop
Do While ie.ReadyState <> 4: DoEvents: Loop
Set doc = ie.document
Set hTable = doc.getElementsByClassName("playerTableTable tableBody")
For Each tb In hTable
Set hBody = tb.getElementsByTagName("tbody")
For Each bb In hBody
Set hTR = bb.getElementsByTagName("tr")
For Each tr In hTR
Set hTD = tr.getElementsByTagName("td")
y = 1 ' Resets back to column A
For Each td In hTD
ws.Cells(z, y).Value = td.innerText
y = y + 1
Next td
DoEvents
z = z + 1
Next tr
Exit For
Next bb
Exit For
Next tb
variable = variable + 40
GoTo Here:
End Sub
I read somewhere that adding (below) might help though its as yet to work for me.
buttonFound = True
While buttonFound
Set allLinks = ie.getElementsByTagName("a")
buttonFound = False
For Each btn In allLinks
If btn.innerText = "Next"
buttonFound = True
Set btnNext = btn
Exit For
End If
Next btn
btn.Click
End Sub
Try this:
' FindNextButton()
Set allLinks = ie.getElementsByTagName("a")
For Each btn In allLinks
If btn.innerText = "Next"
btn.Click
Goto Here
Exit For
End If
Next btn
I have a small piece of code that lists links in a site.
Sub ListLinks()
'Set a reference to microsoft Internet Controls
Dim IeApp As InternetExplorer
Dim sURL As String
Dim IeDoc As Object
Dim i As Long
Set IeApp = New InternetExplorer
IeApp.Visible = True
sURL = "http://www.sharenet.co.za/v3/q_sharelookup.php"
IeApp.Navigate sURL
Do
Loop Until IeApp.ReadyState = READYSTATE_COMPLETE
Set IeDoc = IeApp.Document
For i = 0 To IeDoc.Links.Length - 1
Cells(i + 1, 1).Value = IeDoc.Links(i).href
Next i
Set IeApp = Nothing
End Sub
That is very useful for listing all links in a site. How can I loop through these URLs and import data from each one?
For instance, the first link under 'Name or Sector' is this:
http://www.sharenet.co.za/v3/sharesfound.php?ssector=0533&exch=JSE&bookmark=Oil & Gas&scheme=default
There is actually nothing to import from there. The next link has some data:
http://www.sharenet.co.za/v3/sharesfound.php?ssector=0537&exch=JSE&bookmark=Oil%20-%20Integrated&scheme=default
The data from there looks like this:
Name Full Name Code Sector
SACOIL-N Sacoil Holdings Ltd NPL SCLN 0537
ERIN Erin Energy Corporation ERN 0537
BEE-SASOL BEE - SASOL LIMITED SOLBE1 0537
SACOIL SACOIL HOLDINGS LD SCL 0537
OANDO OANDO PLC OAO 0537
OANDORIGT OANDO PLC RIGT OAON 0537
MONTAUK Montauk Holdings Ltd MNK 0537
How can I import that data from each link?
This seems to work pretty well. It may need a bit of fine tuning, but this should be pretty darn close.
Sub ListLinks()
'Set a reference to microsoft Internet Controls
Dim IeApp As InternetExplorer
Dim sURL As String
Dim IeDoc As Object
Dim i As Long
Set IeApp = New InternetExplorer
IeApp.Visible = True
sURL = "http://www.sharenet.co.za/v3/q_sharelookup.php"
IeApp.Navigate sURL
Do
Loop Until IeApp.ReadyState = READYSTATE_COMPLETE
Set IeDoc = IeApp.Document
For i = 0 To IeDoc.Links.Length - 1
Cells(i + 1, 1).Value = IeDoc.Links(i).href
Next i
Set IeApp = Nothing
Call CopyFromURL
End Sub
Public Sub CopyFromURL()
Dim IE As InternetExplorer, doc As HTMLDocument
Dim thisClass As IHTMLElement2, thisLink As IHTMLElement
Dim rng As Range, cell As Range
Const READYSTATE_COMPLETE As Integer = 4
Dim TR_col As Object, TR As Object
Dim TD_col As Object, TD As Object
Dim row As Long, col As Long
row = 1
Set rng = Range("A1:A5")
For Each cell In rng
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate cell
Do While (IE.Busy Or IE.ReadyState <> READYSTATE_COMPLETE)
DoEvents
Loop
Set TR_col = IE.Document.getElementsByTagName("TR")
For Each TR In TR_col
Set TD_col = TR.getElementsByTagName("TD")
col = 2
For Each TD In TD_col
Cells(row, col) = TD.innerText
col = col + 1
Next
col = 2
row = row + 1
Next
Next cell
IE.Quit
End Sub