Hello I'm trying to get multiple results from a website, depending on the value in column E, filling all cells in the column H.
I'm wondering if there is a way to pause the execution if a captcha pop-up is opened.
Please do not mention Selenium. Either I'm not interested in OCR, I only want the program stops and waits for solving the captcha puzzle.
Sub getPEC()
Dim MyHTML_Element As IHTMLElement
Dim HTMLDoc As HTMLDocument
Dim MyURL As String
Dim results As IHTMLElementCollection
Dim MyBrowser As Object
MyURL = "https://www.registroimprese.it/home"
Set MyBrowser = New InternetExplorer
MyBrowser.Silent = True
MyBrowser.navigate MyURL
MyBrowser.Visible = True
While Selection.Column = 5 And ActiveCell.Value <> ""
Dim r As VbMsgBoxResult
Do
DoEvents
Loop Until MyBrowser.readyState = READYSTATE_COMPLETE
Application.Wait Now + TimeValue("00:00:02")
Set HTMLDoc = MyBrowser.document
HTMLDoc.getElementById("inputSearchFieldMob").Value = Selection.Value
HTMLDoc.getElementById("selProvincia-Mob").Value = Range("P" & Selection.Row).Value
HTMLDoc.getElementById("btnCercaGratuitaMob").Click
Do
DoEvents
Loop Until MyBrowser.readyState = READYSTATE_COMPLETE
Application.Wait Now + TimeValue("00:00:03")
If a captcha pop-up is present Then
r = MsgBox("continue?", vbYesNo, "Captcha?")
If r = vbNo Then Exit Sub
End If
Set tbody = HTMLDoc.getElementsByClassName("table tableRisultatiGratuita")(0).getElementsByTagName("tbody")(0)
Set datarow = tbody.getElementsByTagName("tr")
If datarow.Length = 1 Then
Set datarowtdlist = datarow(0).getElementsByTagName("td")
Set datarowDIVlist = datarowtdlist(0).getElementsByTagName("DIV")
Set datarowAlist = datarowDIVlist(0).getElementsByTagName("A")
MyBrowser.navigate datarowAlist(0).href
Do
DoEvents
Loop Until MyBrowser.readyState = READYSTATE_COMPLETE
Else
r = MsgBox("Select one", vbOKCancel)
If r = vbCancel Then Exit Sub
End If
Set HTMLDoc = MyBrowser.document
Range("H" & Selection.Row).Value = HTMLDoc.getElementsByClassName("ddPec")(0).Value
MyBrowser.GoBack
Range("E" & ActiveCell.Row + 1).Select
i = i + 1
Wend
End Sub
Related
I'm trying to use Excel VBA to extract some data from a webpage (https://www.churchofjesuschrist.org/maps/meetinghouses/lang=eng&q=1148+W+100+N). The code I'm using will open Internet Explorer, navigate to the website, and it will extract the top most result. But I can't seem to figure out how to extract the rest of the results (i.e. ward, language, contact name, contact #). Thoughts?
Sub MeethinghouseLocator()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate Sheets("Sheet1").Range("A1").Value
IE.Visible = True
While IE.Busy
DoEvents
Wend
Application.Wait (Now + TimeValue("0:00:01"))
IE.document.querySelector("button.search-input__execute.button--primary").Click
Dim Doc As HTMLDocument
Set Doc = IE.document
Application.Wait (Now + TimeValue("0:00:01"))
'WardName
Dim aaaaFONT As String
aaaaFONT = Trim(Doc.getElementsByClassName("location-header__name ng-binding")(0).innerText)
Sheets("Sheet1").Range("D6").Value = aaaaFONT
Application.Wait (Now + TimeValue("0:00:01"))
'Language
Dim aaabFONT As String
aaabFONT = Trim(Doc.getElementsByClassName("location-header__language ng-binding ng-scope")(0).innerText)
Sheets("Sheet1").Range("E6").Value = aaabFONT
'Click 1st Link
IE.document.getElementsByClassName("location-header__name ng-binding")(0).Click
Application.Wait (Now + TimeValue("0:00:01"))
'Contact Name
Dim aaacFONT As String
aaacFONT = Trim(Doc.getElementsByClassName("maps-card__group maps-card__group--inline ng-scope")(2).innerText)
Sheets("Sheet1").Range("H6").Value = aaacFONT
'Contact Name Function
Range("F6").Select
ActiveCell.FormulaR1C1 = _
"=LEFT(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3),FIND(RIGHT(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3),LEN(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))-FIND(CHAR(10),RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))),RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))-1)"
'Contact Phone Number
Dim aaadFONT As String
aaadFONT = Trim(Doc.getElementsByClassName("phone ng-binding")(0).innerText)
Sheets("Sheet1").Range("G6").Value = aaadFONT
IE.Quit
End Sub
Most of your code works actually so I'm not sure what issue are you facing but you didn't account for the loading after clicking each link so I have added While loop to check for its Ready and ReadyState property before continuing.
EDIT: The code now loops through all the wards listed in the result, the idea is to keep the first IE at the result page and pass the URL of the ward and the input row to sub ExtractWard where it will open another IE, navigate to the given URL and extract the ward details.
Sub MeethinghouseLocator()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate Sheets("Sheet1").Range("A1").Value
IE.Visible = True
While IE.Busy Or IE.readyState <> 4
DoEvents
Wend
IE.document.querySelector("button.search-input__execute.button--primary").Click
While IE.Busy Or IE.readyState <> 4
DoEvents
Wend
Dim Doc As HTMLDocument
Set Doc = IE.document
Application.Wait (Now + TimeValue("0:00:01"))
Dim wardContent As Object
Set wardContent = Doc.getElementsByClassName("maps-card__content")(2)
Dim wardCollection As Object
Set wardCollection = wardContent.getElementsByClassName("location-header")
Dim rowNum As Long
rowNum = 6
Dim i As Long
For i = 0 To wardCollection.Length - 1
With wardCollection(i)
'WardName
Dim aaaaFONT As String
aaaaFONT = Trim(.getElementsByClassName("location-header__name ng-binding")(0).innerText)
Sheets("Sheet1").Cells(rowNum, "D").Value = aaaaFONT
'Language
Dim aaabFONT As String
aaabFONT = Trim(.getElementsByClassName("location-header__language ng-binding ng-scope")(0).innerText)
Sheets("Sheet1").Cells(rowNum, "E").Value = aaabFONT
Dim wardURL As String
wardURL = .getElementsByClassName("location-header__name ng-binding")(0).href
ExtractWard wardURL, rowNum
End With
rowNum = rowNum + 1
Next i
Set Doc = Nothing
IE.Quit
Set IE = Nothing
End Sub
Private Sub ExtractWard(argURL As String, argRow As Long)
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate argURL
IE.Visible = True
While IE.Busy Or IE.readyState <> 4
DoEvents
Wend
Dim Doc As HTMLDocument
Set Doc = IE.document
'Contact Name
Dim aaacFONT As String
aaacFONT = Trim(Doc.getElementsByClassName("maps-card__group maps-card__group--inline ng-scope")(2).innerText)
Sheets("Sheet1").Cells(argRow, "H").Value = aaacFONT
'Contact Name Function
Sheets("Sheet1").Cells(argRow, "F").FormulaR1C1 = _
"=LEFT(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3),FIND(RIGHT(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3),LEN(RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))-FIND(CHAR(10),RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))),RIGHT(RC[2],LEN(RC[2])-FIND(CHAR(10),RC[2])-3))-1)"
'Contact Phone Number
Dim aaadFONT As String
aaadFONT = Trim(Doc.getElementsByClassName("phone ng-binding")(0).innerText)
Sheets("Sheet1").Cells(argRow, "G").Value = aaadFONT
Set Doc = Nothing
IE.Quit
Set IE = Nothing
End Sub
I am trying to scrape the vaccination data from the below CDC website:
https://covid.cdc.gov/covid-data-tracker/#vaccinations
I have tried querySelectorAll but no luck. Can anyone help take a look? Much appreciated!
Sub useClassnames()
Dim appIE As Object
Set appIE = CreateObject("internetexplorer.application")
With appIE
.navigate "https://covid.cdc.gov/covid-data-tracker/#vaccinations"
.Visible = False
End With
Do While appIE.Busy
DoEvents
Loop
Set allRowOfData = appIE.document.getElementById("maincontent")
Debug.Print allRowOfData.innerHTML
'Set element = appIE.document.querySelectorAll(".container mt-5")
'For Each elements In element
' Debug.Print elements
'Next elements
'For Each element In allRowOfData
'Debug.Print element
'Next element
End Sub
Here you have, just change your worksheet name or number :)
Option Explicit
Const updatedCol = 1
Const dosesDistributedColVal = 2
Const peopleInicVaccColVal = 3
Sub useClassnames()
'declare worksheet variable and set headers
Dim targetWsh As Worksheet: Set targetWsh = ThisWorkbook.Sheets(1)
targetWsh.Cells(1, 1).Value = "Last Update"
targetWsh.Cells(1, 2).Value = "Doses Distributed"
targetWsh.Cells(1, 3).Value = "People Initiating Vaccination"
Dim lstRegisterRow As Long: lstRegisterRow = targetWsh.Range("A" & targetWsh.Rows.Count).End(xlUp).Row + 1
'open IE and navigate to site
Dim appIE As InternetExplorer: Set appIE = New InternetExplorer
appIE.navigate "https://covid.cdc.gov/covid-data-tracker/#vaccinations"
appIE.Visible = False
While appIE.Busy = True Or appIE.readyState < 4: DoEvents: Wend
Dim oHtmlDoc As HTMLDocument: Set oHtmlDoc = appIE.document
Dim oHtmlElementColl As IHTMLElementCollection
'Get and write last update date
Application.Wait (Now + TimeValue("0:00:02")) 'wait 2 secs to avoid error, if recieve error, add seconds as needed
Set oHtmlElementColl = oHtmlDoc.getElementsByTagName("small")
targetWsh.Cells(lstRegisterRow, updatedCol) = oHtmlElementColl(0).innerHTML
'Get and write Doses Distributed and People Initiating Vaccination
Set oHtmlElementColl = oHtmlDoc.GetElementsByClassName("card-number")
targetWsh.Cells(lstRegisterRow, dosesDistributedColVal) = oHtmlElementColl(0).innerText
targetWsh.Cells(lstRegisterRow, peopleInicVaccColVal) = oHtmlElementColl(1).innerText
appIE.Quit
End Sub
This is the code that i am using. No error on the macro but there is also no output on the excel sheet.
I am trying to get the data on the table for all the shares.
Sub sqylogin()
On Error Resume Next
Dim ie, objShell, Wnd As Object
Set objShell = CreateObject("Shell.Application")
Application.Calculation = xlManual
ieopen = True
For Each Wnd In objShell.Windows
If Right(Wnd.Name, 17) = "Internet Explorer" Then
Set ie = Wnd
ieopen = False
Exit For
End If
Next Wnd
If ieopen Then Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
p = "https://www.pse.com.ph/stockMarket/marketInfo-marketActivity.html?tab=1&indexName=All%20Shares"
ie.navigate (p): Application.Wait (Now + #12:00:59 AM#)
Set divelements = ie.Document.getElementsbytagname("div")
Cells(1, 1) = Now: c = 2
For Each divelement In divelements
If divelement.ID = "ext-gen291" Then
For j = 0 To 300
For i = 0 To 8
Cells(c + j, i + 1).Value = divelement.Children(j).Children(0).Children(0).Children(0).Children(i).innertext
Next i
Next j
End If
Next divelement
Set ie = Nothing
Application.Calculation = xlCalculationAutomatic
End Sub
The tables within the parent div are dynamically loaded via an ajax call so you need some sort of wait condition to ensure they are present. I show a wait condition based on the number of child tables present and additionally use the clipboard to copy paste the child tables to the sheet.
Option Explicit
Public Sub GetMarketActivity()
Dim ie As SHDocVw.InternetExplorer, clipboard As Object
Set ie = New SHDocVw.InternetExplorer
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
Dim t As Date
Const MAX_WAIT_SEC As Long = 360
With ie
.Visible = True
.Navigate2 "https://www.pse.com.ph/stockMarket/marketInfo-marketActivity.html?tab=1&indexName=All%20Shares"
Do
DoEvents
Loop While .Busy Or .readyState <> READYSTATE_COMPLETE
t = Timer
Do
DoEvents
If Timer - t > MAX_WAIT_SEC Then Exit Sub
Loop Until .document.querySelectorAll(".x-grid3-row-table").Length > 1 '<wait for more than one record (Table)
Dim tables As Object, i As Long, headers()
Set tables = .document.querySelectorAll(".x-grid3-row-table")
headers = Array("Record", "Symbol", "Last trade date", "Last trade price", "Outstanding shares")
For i = 0 To tables.Length - 1
clipboard.SetText tables.item(i).outerHTML
clipboard.PutInClipboard
With ActiveSheet
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(i + 2, 1).PasteSpecial
End With
Next
.Quit
End With
End Sub
I am trying to select data from the dropdown in the web URL, my all code is working fine but I am unable to select the value from the dropdown.
Sub pulldata2()
Dim tod As String, UnderLay As String
Dim IE As Object
Dim doc As HTMLDocument
'Html table
Dim Tbl As HTMLTable, Cel As HTMLTableCell, Rw As HTMLTableRow, Col As HTMLTableCol
Dim TrgRw As Long, TrgCol As Long
'Create new sheet
tod = ThisWorkbook.Sheets("URLList").Range("C2").Value
have = False
For Each sht In ThisWorkbook.Sheets
If sht.Name = tod Then
have = True
Exit For
End If
Next sht
If have = False Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = tod
Else
If MsgBox("Sheet " & tod & " already exists Overwrite Data?", vbYesNo) = vbNo Then Exit Sub
End If
'Start Internetexplorer
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.navigate "https://nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?segmentLink=17&instrument=OPTIDX&symbol=NIFTY&date=25APR2019"
Do While IE.Busy Or IE.readyState <> 4
Application.Wait DateAdd("s", 1, Now)
Loop
Set doc = IE.document
Dim ColOff As Long
'Put data to sheet and loop to next URL
For Nurl = 2 To 191
ColOff = (Nurl - 2) * 23
TrgRw = 1
UnderLay = ThisWorkbook.Sheets("URLList").Range("A" & Nurl).Value
doc.getElementById("underlyStock").Value = UnderLay
doc.parentWindow.execScript "goBtnClick('stock');", "javascript"
'now i want to select data from dropdown id=date, value= 27JUN2019
doc.querySelector("Select[name=date] option[value=27JUN2019]").Selected = True
Do While IE.Busy Or IE.readyState <> 4
Application.Wait DateAdd("s", 1, Now)
Loop
Set Tbl = doc.getElementById("octable")
ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + 1).Value = UnderLay
ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + 1).Font.Size = 20
ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + 1).Font.Bold = True
ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + 1).Select
TrgRw = TrgRw + 1
For Each Rw In Tbl.Rows
TrgCol = 1
For Each Cel In Rw.Cells
ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + TrgCol).Value = Cel.innerText
TrgCol = TrgCol + Cel.colSpan ' if Column span is > 1 multiple
Next Cel
TrgRw = TrgRw + 1
Next Rw
TrgRw = TrgRw + 1
Next Nurl
'exit the internetexplorer
IE.Quit
Set IE = Nothing
End Sub
why my code not working, I am new in VBA please help to find an error in my code.
Simply alter the url rather than use dropdown
https://nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?segmentLink=17&instrument=OPTIDX&symbol=NIFTY&date=27JUN2019
You can also use xhr to get the content rather than a slow browser. I use the clipboard to write out the table.
Option Explicit
Public Sub GetInfo()
Dim html As Object, hTable As Object, ws As Worksheet, clipboard As Object
Set html = New HTMLDocument
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?segmentLink=17&instrument=OPTIDX&symbol=NIFTY&date=27JUN2019", False
.send
html.body.innerHTML = .responseText
Set hTable = html.getElementById("octable")
clipboard.SetText hTable.outerHTML
clipboard.PutInClipboard
ws.Range("A1").PasteSpecial
End With
End Sub
Alternative:
1) You could loop the tr and td within hTable above to write out the table
2) You could also use powerquery from web (via data tab Excel 2016+ , or using free powerquery add-in for 2013. You paste the url into the top of the pop up browser and press Go then select the table to import.
Changing stocks:
Stocks are part of the url query string e.g. symbol=NIFTY , so you can concatenate the new symbol into the url during a loop
"https://nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?segmentLink=17&instrument=OPTIDX&symbol=" & yourSymbolGoesHere & "&date=27JUN2019"
If you really want to use IE be sure to encase the value of the attribute within '' e.g. '27JUN2019'
Option Explicit
'VBE > Tools > References: Microsoft Internet Controls
Public Sub ClickButton()
Dim ie As InternetExplorer
Const URL As String = "https://nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?segmentLink=17&instrument=OPTIDX&symbol=NIFTY&date=25APR2019"
Set ie = New InternetExplorer
With ie
.Visible = True
.Navigate2 URL
While .Busy Or .readyState < 4: DoEvents: Wend
With .document
.querySelector("[value='27JUN2019']").Selected = True
Stop
End With
End With
End Sub
Iwant to get the href link from the following code:
<div class="border-content">
<div class="main-address">
<h2 class="address">
Marcos paz 2500<span></span>
</h2>
i tried using getelementsbytagname("a") but i don't know how to do that for the specific class "address". Any ideas?
Thanks Kilian, here's how i handle everything. Quite complicated but it worked, although it takes for ever as i have plenty of nested loops:
Sub Propiedades()
'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://www.argenprop.com/Departamentos-tipo-casa-Venta-Almagro-Belgrano-Capital-Federal/piQ86000KpsQ115000KmQ2KrbQ1KpQ1KprQ2KpaQ135Kaf_816Kaf_100000001KvnQVistaResultadosKaf_500000001Kaf_801KvncQVistaGrillaKaf_800000002Kaf_800000005Kaf_800000010Kaf_800000041Kaf_800000011Kaf_800000020Kaf_800000030Kaf_800000035Kaf_800000039Kaf_900000001Kaf_900000002Kaf_900000006Kaf_900000008Kaf_900000009Kaf_900000007Kaf_900000010Kaf_900000033Kaf_900000034Kaf_900000036Kaf_900000038Kaf_900000037Kaf_900000035Kaf_900000039Kaf_900000041Kaf_900000042Kaf_900000043"
'Wait until IE is done loading page
Do While ie.ReadyState <> READYSTATE_COMPLETE
Application.StatusBar = "Trying to go to argenprop ..."
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
Sheets(2).Select
Cells.ClearContents
'put heading across the top of row 3
Range("A3").Value = "Direccion"
Range("B3").Value = "Mts cuadrados"
Range("C3").Value = "Antiguedad"
Range("D3").Value = "Precio"
Range("E3").Value = "Dormitorios"
Range("F3").Value = "Descripcion"
Range("G3").Value = "Link"
Dim PropertyList As IHTMLElement
Dim Properties As IHTMLElementCollection
Dim Property As IHTMLElement
Dim RowNumber As Long
Dim PropertyFields As IHTMLElementCollection
Dim PropertyField As IHTMLElement
Dim PropertyFieldLinks As IHTMLElementCollection
Dim caracteristicasfields As IHTMLElementCollection
Dim caract As IHTMLElement
Dim caracteristicas As IHTMLElementCollection
Dim caractfield As IHTMLElement
Set PropertyList = html.getElementById("resultadoBusqueda")
Set Properties = PropertyList.Children
RowNumber = 4
For Each Property In Properties
If Property.className = "box-avisos-listado clearfix" Then
Set PropertiesFields = Property.all
For Each PropertyField In PropertiesFields
Fede = PropertyField.className
If PropertyField.className Like "avisoitem*" Then
Set caracteristicas = PropertyField.Children
For Each caract In caracteristicas
f = caract.className
If f = "border-content" Then
Set caracteristicasfields = caract.all
For Each caractfield In caracteristicasfields
test1 = caractfield.className
u = caractfield.innerText
If caractfield.className <> "" Then
Select Case caractfield.className
Case Is = "address"
Cells(RowNumber, "A") = caractfield.innerText
marray = Split(caractfield.outerHTML, Chr(34))
Cells(RowNumber, "G") = "www.argenprop.com" & marray(5)
Case Is = "list-price"
Cells(RowNumber, "D") = caractfield.innerText
Case Is = "subtitle"
Cells(RowNumber, "F") = caractfield.innerText 'descripcion
'Case is ="datoscomunes"
'Set myelements = caractfield.all
Case Is = "datocomun-valor-abbr"
Select Case counter
Case Is = 0
Cells(RowNumber, "B") = caractfield.innerText 'square mts
counter = counter + 1
Case Is = 1
Cells(RowNumber, "E") = caractfield.innerText 'DORMITORIOS
counter = counter + 1
Case Is = 2
Cells(RowNumber, "C") = caractfield.innerText ' antiguedad
counter = 0 ' reset counter
Set caracteristicasfields = Nothing
Exit For 'salgo del loop en caractfield
End Select 'cierro el select del counter
End Select 'cierro el select de caractfield.classname
End If ' cierro If caractfield.className <> "" Then
Next caractfield
End If ' cierro el border content
If caract = "border-content" Then Exit For 'salgo del loop dentro de aviso item (caract)
Next caract
RowNumber = RowNumber + 1
End If ' If PropertyField.className Like "avisoitem*"
Next PropertyField 'para ir al siguiente aviso
End If
Next Property
Set html = Nothing
MsgBox "done!"
End Sub