I want to pull calls and puts data from NSE wesbite,In the website, there are 2 dropdown boxes available (Refer the image).For every dropdown change event,the table value changes.
https://www.nseindia.com/option-chain
I am successfully able to update the HTML table values for the first drop down fields using HTML events,
and i am using the same "HTML event" to update the table values when the second drop down index changes,but could not get the work done,can one please help?
I am giving the source code also,please suggess
'Option Data Pulling
Sub Options_Pull_Active_List()
Dim Opt_Url As String
Opt_Url = ActiveSheet.Range("G3").Value
Dim ie As New InternetExplorer
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Top = 0
ie.Left = 0
ie.Width = 1000
ie.Height = 750
ie.AddressBar = 0
ie.StatusBar = 0
ie.Toolbar = 0
ie.navigate Opt_Url
Do
DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE
Dim doc As HTMLDocument
Set doc = ie.document
Dim objElement As HTMLObjectElement
Dim sDD As String
doc.Focus
Dim k1, k2, Opto, Sana As Integer
k1 = ActiveSheet.Range("AL7").Value
k2 = ActiveSheet.Range("AL8").Value
For Opto = k1 To k2
ActiveSheet.Range("AK10").Value = Opto
Sana = ActiveSheet.Range("AL10").Value
'instrumentType
doc.getElementById("select_symbol").Focus 'Setting Instrument Type
Application.Wait Now + TimeValue("00:00:04")
doc.getElementById("select_symbol").selectedIndex = Sana
Dim objEvent
Set objEvent = doc.createEvent("HTMLEvents")
objEvent.initEvent "change", False, True
doc.getElementById("select_symbol").dispatchEvent objEvent 'This code successfully able to updat the HTML page
Application.Wait Now + TimeValue("00:00:05")
doc.getElementById("expirySelect").selectedIndex = 2
doc.getElementById("expirySelect").dispatchEvent objEvent 'This same code does not update the table values
'-------------------------
Application.Wait Now + TimeValue("00:00:03")
Do While ie.Busy Or ie.readyState <> 4
DoEvents
Loop
'------------------
Dim hTable As Object, hBody As Object, hTR As Object, hTD As Object
Dim tb As Object, bb As Object, tr As Object, td As Object
Dim i As Integer
y = 5 ' 'Column A in Excel
Z = 25 ' 'Row 1 in Excel
Set hTable = doc.getElementsByTagName("Table")
'Set hTable = doc.getElementById("historicalData")
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 = 5 ' Resets back to Default Column Set in the Excel Sheet
For i = 0 To hTD.Length
Sheets("M1 - Option Data Pull").Cells(Z, y).Value = hTD(i).innerText
If Trim(Sheets("M1 - Option Data Pull").Cells(Z, y).Value) = "-" Then
Sheets("M1 - Option Data Pull").Cells(Z, y).Value = 0
End If
If i = 11 Then
If hTD(i + 1).getAttribute("class") = "bg-yellow" And Sheets("M1 - Option Data Pull").Range("O1").Value = 0 Then
Sheets("M1 - Option Data Pull").Range("O1").Value = 1
Sheets("M1 - Option Data Pull").Range("O2").Value = hTD(i).innerText
End If
End If
y = y + 1
Next i
DoEvents
Z = Z + 1
Next tr
Exit For
Next bb
Exit For
Next tb
'-------------------
Next Opto
ie.Quit
ie.Visible = True
Set doc = Nothing
Set ie = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Related
I need to scrape date on ever page by clicking page number present in the webpage below.
I have mentioned sample website which looks similar to my html webpage.
Sample web page is this Webpage.
Code i have is below:
Sub Test()
Dim IE As Object
Dim i As Long, strText As String
Dim y As Long, z As Long, wb As Excel.Workbook, ws As Excel.Worksheet
Dim myBtn As Object
Dim Table As Object, tbody As Object, datarow As Object, thlist As Object, trlist As Object
Set wb = Excel.ActiveWorkbook
Set ws = wb.ActiveSheet
Sheets("Data").Select
Set IE = CreateObject("InternetExplorer.Application")
my_url = webpage.com
With IE
.Visible = True
.navigate my_url
Do Until Not IE.Busy And IE.readyState = 4
DoEvents
Loop
End With
Set doc = IE.document
y = 1
z = 1
Application.Wait Now + TimeValue("00:00:02")
Set tbody = IE.document.getElementsByTagName("table")(0).getElementsByTagName("tbody")(0)
Set thlist = tbody.getElementsByTagName("tr")(0).getElementsByTagName("th")
Dim ii As Integer
For ii = 0 To thlist.Length - 1
ws.Cells(z, y).Value = thlist(ii).innerText
y = y + 1
Next ii
Set datarow = tbody.getElementsByTagName("tr")
y = 1
z = 2
Dim jj As Integer
Dim datarowtdlist As Object
For jj = 1 To datarow.Length - 4
Set datarowtdlist = datarow(jj).getElementsByTagName("td")
Dim hh As Integer, x As Integer
x = y
For hh = 0 To datarowtdlist.Length - 1
ws.Cells(z, x).Value = datarowtdlist(hh).innerText
x = x + 1
Next hh
z = z + 1
Next jj
Set IE = Nothing
End Sub
Im happy to help if my question is not clear.
Thanks for the support.
The next page is retrieved by incrementing the __EVENTARGUMENT of the __doPostBack e.g. from 1 to 2, 2 to 3 etc, and then triggering the __doPostBack with the new value. The last page will have been reached when the final td node (in the pagination area) no longer has a child href containing the __EVENTTARGET (sb$grd). Using this logic you can loop, incrementing, and have an exit condition, as shown below.
For more info about this function with ASP.NET see my answer here.
Public Sub LoopPages()
Dim ie As SHDocVw.InternetExplorer
Set ie = New SHDocVw.InternetExplorer
With ie
.Visible = True
.Navigate2 "https://www.mfa.gov.tr/sub.ar.mfa?dcabec54-44b3-4aaa-a725-70d0caa8a0ae"
While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
Dim i As Long
i = 1
Do
Debug.Print i
Debug.Print .document.querySelector(".sub_lstitm").innerText
If .document.querySelectorAll("tr:nth-child(1) td:last-child [href*='sb$grd']").length = 0 Then Exit Do
.document.parentWindow.execScript "__doPostBack('sb$grd','Page$" & i + 1 & "');"
While .Busy Or .readyState <> READYSTATE_COMPLETE: DoEvents: Wend
'do something with new page
i = i + 1
Loop
Stop 'stops at 185
.Quit
End With
End Sub
I would to scrape this site with VBA in Excel, It work and it connects to web site on IE, but doesn't write on worksheet, how can i solve ?
IT: https://www.betfair.it/exchange/plus/it/calcio-scommesse-1/today
COM: https://www.betfair.com/exchange/plus/en/football-betting-1/today
Private Sub Test()
Dim ie As Object, i As Long, strText As String
Dim doc As Object, hTable As Object, hBody As Object, hTR As Object, hTD As Object
Dim tb As Object, bb As Object, tr As Object, 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
ie.navigate "https://www.betfair.it/exchange/plus/inplay/football"
Do While ie.busy: DoEvents: Loop
Do While ie.ReadyState <> 4: DoEvents: Loop
Set doc = ie.document
Set hTable = doc.GetElementsByTagName("table")
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
End Sub
Please read my comments in the code:
Private Sub Test()
Dim ie As Object, i As Long 'strText As String (not used)
Dim main As Object, hTable As Object, hBody As Object, hTR As Object, hTD As Object
Dim tb As Object, bb As Object, tr As Object, 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
ie.navigate "https://www.betfair.it/exchange/plus/inplay/football"
'Do While ie.busy: DoEvents: Loop 'not needed
Do While ie.ReadyState <> 4: DoEvents: Loop
'There are AJAX data to load in the Tables after ReadyState is set to 4 (which means 'complete')
'So you need a manuell break to give the data time to come in
Application.Wait (Now + TimeSerial(0, 0, 5))
'Set doc = ie.document 'Not needed
'At first you must grab the HTML area which includes the tables you want
'Without this you get only the first table in the whole HTML document
'which lays in the header of the page
Set main = ie.document.GetElementsByTagName("main")(0)
'From here it's your code
'I think you will soon see that it is not enough just to read the inner text of the TD tags
'You will have to split it further. But that is your next planned step I think.
Set hTable = main.GetElementsByTagName("table")
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
End Sub
How to Extract Below table in Excel from Webpage?
Table
Company | Bonus Ratio |Announcement|Record|Ex-Bonus
Codes
Dim ie As SHDocVw.InternetExplorer
Set ie = New InternetExplorerMedium
Set ie = CreateObject("InternetExplorer.Application")
While ie.busy
DoEvents
Wend
ie.Visible = True
While ie.busy
DoEvents
Wend
Dim NavURL As String
NavURL = "https://www.moneycontrol.com/stocks/marketinfo/bonus/homebody.php?sel_year=2015"
ie.Navigate NavURL
While ie.busy
DoEvents
Wend
Set doc = ie.document
Set hTable = doc.GetElementsByTagName("table")
y = 2 'Column B in Excel
z = 7 'Row 7 in Excel
For Each td In hTable
Set hHead = tb.GetElementsByTagName("td")
For Each hh In hHead
Set hTR = hh.GetElementsByTagName("tr")
For Each tr In hTR
Webpage: https://www.moneycontrol.com/stocks/marketinfo/bonus/homebody.php?sel_year=2015
by Keeping Bonus Ratio as Same as on Webpage or Text Format
While copy it in Excel, Bonus Ratio Converts to Decimal
Your hTable is a collection as opposed to a single element. Your code should be throwing an error.
You want to target the specific table and then loop the table rows and cells within rows. You want to check if the second column is being processed so you can protect the formatting of the ratios. You also want to monitor the row number to handle the merged cells at the top.
Option Explicit
Public Sub GetInfo()
Const URL As String = "https://www.moneycontrol.com/stocks/marketinfo/bonus/homebody.php?sel_year=2015"
Dim html As HTMLDocument, hTable As HTMLTable, ws As Worksheet, headers()
headers = Array("Company", "Bonus Ratio", "Announcement", "Record", "Ex-bonus")
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.Send
html.body.innerHTML = .responseText
End With
Set hTable = html.querySelector("table.dvdtbl")
Dim td As Object, tr As Object, r As Long, c As Long
r = 1
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
For Each tr In hTable.getElementsByTagName("tr")
r = r + 1: c = 1
If r > 3 Then
For Each td In tr.getElementsByTagName("td")
.Cells(r - 2, c) = IIf(c = 2, "'" & td.innerText, td.innerText)
c = c + 1
Next
End If
Next
End With
End Sub
I am trying to scrap a list of href link from a webpage, and then trying to scrap the value out of it. I am now facing the problem which the code only can handle up to 5 links. If the links more than 5, it will show runtime error on random line.
I am extracting the href link from these webpage:http://www.bursamalaysia.com/market/listed-companies/company-announcements/#/?category=SH&sub_category=all&alphabetical=All&date_from=28/09/2018
Option Explicit
Sub ScrapLink()
Dim IE As New InternetExplorer, html As HTMLDocument
Application.ScreenUpdating = False
With IE
IE.Visible = False
IE.navigate Cells(1, 1).Value
While .Busy Or .readyState < 4: DoEvents: Wend
Application.Wait Now + TimeSerial(0, 0, 3)
Application.StatusBar = "Trying to go to website?"
DoEvents
Dim links As Object, i As Long
Set links = .document.querySelectorAll("#bm_ajax_container [href^='/market/listed-companies/company-announcements/']")
For i = 1 To links.Length
With ThisWorkbook.Worksheets("Sheet1")
.Cells(i + 1, 1) = links.item(i - 1)
End With
Next i
.Quit
End With
End Sub
Public Sub GetInfo()
Dim IE As New InternetExplorer, headers(), u As Long, resultCollection As Collection
headers = Array("URL", "Name", "No", "Date of change", "# Securities", "Type of Transaction", "Nature of Interest")
Set resultCollection = New Collection
Dim links()
links = Application.Transpose(ThisWorkbook.Worksheets("Sheet1").Range("A2:A100"))
With IE
.Visible = True
For u = LBound(links) To UBound(links)
If InStr(links(u), "http") > 0 Then
.navigate links(u)
While .Busy Or .readyState < 4: DoEvents: Wend
Application.Wait Now + TimeSerial(0, 0, 2)
Dim data As Object, title As Object
With .document.getElementById("bm_ann_detail_iframe").contentDocument
Set title = .querySelector(".formContentData")
Set data = .querySelectorAll(".ven_table tr")
End With
Dim results(), numberOfRows As Long, i As Long, currentRow As Object, td As Object, c As Long, r As Long
numberOfRows = Round(data.Length / 4, 0)
ReDim results(1 To numberOfRows, 1 To 7)
For i = 0 To numberOfRows - 1
r = i + 1
results(r, 1) = links(u): results(r, 2) = title.innerText
Set currentRow = data.item(i * 4 + 1)
c = 3
For Each td In currentRow.getElementsByTagName("td")
results(r, c) = Replace$(td.innerText, "document.write(rownum++);", vbNullString)
c = c + 1
Next td
Next i
resultCollection.Add results
Set data = Nothing: Set title = Nothing
End If
Next u
.Quit
End With
Dim ws As Worksheet, item As Long
If Not resultCollection.Count > 0 Then Exit Sub
If Not Evaluate("ISREF('Results'!A1)") Then '<==Credit to #Rory for this test
Set ws = Worksheets.Add
ws.NAME = "Results"
Else
Set ws = ThisWorkbook.Worksheets("Results")
ws.Cells.Clear
End If
Dim outputRow As Long: outputRow = 2
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
For item = 1 To resultCollection.Count
Dim arr()
arr = resultCollection(item)
For i = LBound(arr, 1) To UBound(arr, 1)
.Cells(outputRow, 1).Resize(1, 7) = Application.WorksheetFunction.Index(arr, i, 0)
outputRow = outputRow + 1
Next
Next
End With
End Sub
Discussion:
The problem is likely, at least from my testing, due to one of the links not having the table Details of changes, so the numberOfRows variable is set to 0, and this line:
ReDim results(1 To numberOfRows, 1 To 7)
fails with an index error as you have (1 To 0, 1 To 7).
Using this link in A1 there are 30 URLs retrieved. This retrieved link does not have that table whereas the others do.
You have a choice of how to handle this scenario. Here are some example options:
Option 1: Only process the page if the numberOfRows > 0. This is the example I give.
Option 2: Have a Select Case with numberOfRows and if Case 0 then handle page in one way, Case Else handle as normal.
Note:
1) You also want to reset the status bar with:
Application.StatusBar = False
2) I temporarily fixed the links range for testing with:
ThisWorkbook.Worksheets("Sheet1").Range("A2:A31")
TODO:
Refactor to be more modular and run the whole process with the same IE instance. Creating a class to hold the IE object would be a good idea. Provide it with methods for extracting your data, testing number of result rows etc.
Add some basic error handling, for example, to handle failed website connection.
Example handling using test of numberOfRows > 0:
Option Explicit
Sub ScrapeLink()
Dim IE As New InternetExplorer
Application.ScreenUpdating = False
With IE
IE.Visible = True
IE.navigate Cells(1, 1).Value
While .Busy Or .readyState < 4: DoEvents: Wend
' Application.Wait Now + TimeSerial(0, 0, 3)
Application.StatusBar = "Trying to go to website?"
DoEvents
Dim links As Object, i As Long
Set links = .document.querySelectorAll("#bm_ajax_container [href^='/market/listed-companies/company-announcements/']")
For i = 1 To links.Length
With ThisWorkbook.Worksheets("Sheet1")
.Cells(i + 1, 1) = links.item(i - 1)
End With
Next i
.Quit
End With
Application.StatusBar = false
End Sub
Public Sub GetInfo()
Dim IE As New InternetExplorer, headers(), u As Long, resultCollection As Collection
headers = Array("URL", "Name", "No", "Date of change", "# Securities", "Type of Transaction", "Nature of Interest")
Set resultCollection = New Collection
Dim links()
links = Application.Transpose(ThisWorkbook.Worksheets("Sheet1").Range("A2:A31")) '<== I have fixed the range here for testing
With IE
.Visible = True
For u = LBound(links) To UBound(links)
If InStr(links(u), "http") > 0 Then
.navigate links(u)
While .Busy Or .readyState < 4: DoEvents: Wend
Application.Wait Now + TimeSerial(0, 0, 2)
Dim data As Object, title As Object
With .document.getElementById("bm_ann_detail_iframe").contentDocument
Set title = .querySelector(".formContentData")
Set data = .querySelectorAll(".ven_table tr")
End With
Dim results(), numberOfRows As Long, i As Long, currentRow As Object, td As Object, c As Long, r As Long
numberOfRows = Round(data.Length / 4, 0)
If numberOfRows > 0 Then
ReDim results(1 To numberOfRows, 1 To 7)
For i = 0 To numberOfRows - 1
r = i + 1
results(r, 1) = links(u): results(r, 2) = title.innerText
Set currentRow = data.item(i * 4 + 1)
c = 3
For Each td In currentRow.getElementsByTagName("td")
results(r, c) = Replace$(td.innerText, "document.write(rownum++);", vbNullString)
c = c + 1
Next td
Next i
resultCollection.Add results
Set data = Nothing: Set title = Nothing
End If
End If
Next u
.Quit
End With
Dim ws As Worksheet, item As Long
If Not resultCollection.Count > 0 Then Exit Sub
If Not Evaluate("ISREF('Results'!A1)") Then '<==Credit to #Rory for this test
Set ws = Worksheets.Add
ws.NAME = "Results"
Else
Set ws = ThisWorkbook.Worksheets("Results")
ws.Cells.Clear
End If
Dim outputRow As Long: outputRow = 2
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
For item = 1 To resultCollection.Count
Dim arr()
arr = resultCollection(item)
For i = LBound(arr, 1) To UBound(arr, 1)
.Cells(outputRow, 1).Resize(1, 7) = Application.WorksheetFunction.Index(arr, i, 0)
outputRow = outputRow + 1
Next
Next
End With
End Sub
Sample results:
tr---- 0495024988
14.08.1996
04/04/130/02514/AM96/
23.01.1996
0495024988
6. tr----(here the text is there which i have copy to my excel sheet)
here i have read many post where the javascript code is given but the vba code is not there. please help me out of this.
Sub GoToWebSiteAndPlayAroundNew()
Dim appIE As Object ' InternetExplorer.Application
Dim URL As String
Dim i As Long, strText As String
Dim doc As Object, hTable As Object, hBody As Object, hTR As Object, hTD As Object
Dim tb As Object, bb As Object, tr As Object, td As Object
Dim y As Long, z As Long, wb As Excel.Workbook, ws As Excel.Worksheet
Dim sws As SHDocVw.ShellWindows
Dim IE As Object
Dim vIE As SHDocVw.InternetExplorer
Set wb = Excel.ActiveWorkbook
Set ws = wb.ActiveSheet
Set appIE = CreateObject("InternetExplorer.Application")
URL = "http://dgft.delhi.nic.in:8100/dgft/IecPrint"
y = 1 'Column A in Excel
z = 1 'Row 1 in Excel
With appIE
.navigate URL
.Visible = True
Do While .busy: DoEvents: Loop
Do While .ReadyState <> 4: DoEvents: Loop
.document.getElementById("iec").Value = "0495024988"
.document.getElementById("name").Value = "AMB"
End With
On Error Resume Next
With appIE.document
Set elems = .getElementsByTagName("input")
For Each e In elems
If (e.getAttribute("value") = "Submit Query") Then
e.Click
Exit For
End If
Next e
End With
Set sws = New SHDocVw.ShellWindows
For Each vIE In sws
'If Left(vIE.LocationURL, 4) = "http" Then 'avoid explorer windows/etc this way
'If MsgBox("IE Window found. The URL is:" & vbCrLf & vIE.LocationURL & vbCrLf & _
'vbCrLf & "Do you want to see the html?", vbYesNo) = vbYes Then
'Show html in a msgbox
' MsgBox vIE.document.body.innerHTML
'Or put it to a file
'dim vFF as long
'vff=freefile
'open "C:\thehtml.txt" for output as #vff
'print #vff,vie.document.body.innerhtml
'close #vff
' End If
'End If
Set doc = vIE.document
Set hTable = doc.getElementsByTagName("table")
For Each tb In hTable
Set hBody = tb.getElementsByTagName("tbody")
For Each bb In hBody
Set hTR = bb.getElementsByTagName("tr")
MsgBox hTR.Length
For Each tr In hTR
Set hTD = tr.getElementsByTagName("td")
MsgBox hTD.Length
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
Next
End Sub