Complete online form VBA - html

I have created a test form here and I am trying to fill it out with values I have in an excel file.
My code stops at the line: 'Call ie.Document.getelementbyid("input_11").setAttribute("value", activity)' and it does not copy the data from the first cell, this is how my excel file looks like:
'Sub internet()
Dim ie As Object
Dim activitate As String
Dim LastRow As Long
Dim i, j As Integer
i = 1
LastRow = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row - 1
j = 0
'open page
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
ie.Navigate "https://form.jotformeu.com/91133129129351"
Do
DoEvents
Loop Until ie.ReadyState = 4
While i < 11
For Each c In Range("2:2")
activity = c.Value
Call ie.Document.getelementbyid("input_11").setAttribute("value", activity)
Next c
Wend
End Sub'
I'm trying to get past this code error, thank you for your time!

I think somethink like that must be
Sub test()
Dim IeApp As Object
Dim IeDoc As Object
Dim ieEL As Object
Set IeApp = CreateObject("InternetExplorer.Application")
IeApp.Visible = True ' make Explorer visible
IeApp.Navigate "https://form.jotformeu.com/91133129129351"
Do While IeApp.Busy: DoEvents: Loop ' wait for page load
'Do Until IeApp.readyState = READYSTATE_COMPLETE: DoEvents: Loop
Set IeDoc = IeApp.Document ' set loaded content to variable
For Each ieEL In IeDoc.getElementsByTagName("input") ' loop all inputs
If InStr(ieEL.Name, "activitate") > 0 Then ' check if inputs name has activate name
i = i + 1 ' increment for pick up valaues from sheet
ieEL.Value = ThisWorkbook.ActiveSheet.Cells(2, i).Value ' set value from sheets 2 row and i column
End If
Next
End Sub

Related

Extract table from webpage using VBA

I would like to extract the table from html code into Excel using VBA.
I have tried the following code several times with changing some of the code but keep on getting error.
Sub GrabTable()
'dimension (set aside memory for) our variables
Dim objIE As InternetExplorer
Dim ele As Object
Dim y As Integer
'start a new browser instance
Set objIE = New InternetExplorer
'make browser visible
objIE.Visible = False
'navigate to page with needed data
objIE.navigate "http://www.bursamalaysia.com/market/listed-companies/company-announcements/5923061"
'wait for page to load
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
'we will output data to excel, starting on row 1
y = 1
'look at all the 'tr' elements in the 'table' with id 'InputTable2',
'and evaluate each, one at a time, using 'ele' variable
For Each ele In objIE.document.getElementByClassName("InputTable2").getElementsByTagName("tr")
'show the text content of 'td' element being looked at
Debug.Print ele.textContent
'each 'tr' (table row) element contains 2 children ('td') elements
'put text of 1st 'td' in col A
Sheets("Sheet1").Range("A" & y).Value = ele.Children(0).textContent
'put text of 2nd 'td' in col B
Sheets("Sheet1").Range("B" & y).Value = ele.Children(1).textContent
y = y + 1
'repeat until last ele has been evaluated
Next
End Sub
I show you two methods:
Using IE: The data is inside an iframe which needs to be negotiated
Using XMLHTTP request - much faster and without browser opening. It uses the first part of the iframe document URL which is what the iframe is navigating to.
In both cases I access the tables containing the company name and then the disclosure info table. For the disclosure main info table I copy the outerHTML to the clipboard and paste to Excel to avoid looping all the rows and columns. You can simply set loop the tr (table rows) and td (table cells) within instead.
IE:
Option Explicit
Public Sub GetInfo()
Dim IE As New InternetExplorer, clipboard As Object
With IE
.Visible = True
.navigate "http://www.bursamalaysia.com/market/listed-companies/company-announcements/5923061"
While .Busy Or .readyState < 4: DoEvents: Wend
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
With .document.getElementById("bm_ann_detail_iframe").contentDocument
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1) = .getElementsByClassName("company_name")(0).innerText
clipboard.SetText .getElementsByTagName("table")(1).outerHTML
clipboard.PutInClipboard
End With
ThisWorkbook.Worksheets("Sheet1").Cells(2, 1).PasteSpecial
.Quit
End With
End Sub
XMLHTTP:
You can extract a different URL from the front-end of the iframe URL and use that as shown below.
Here is the section of your original HTML that shows the iframe and the associated new URL info:
Option Explicit
Public Sub GetTable()
Dim sResponse As String, html As HTMLDocument, clipboard As Object
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://disclosure.bursamalaysia.com/FileAccess/viewHtml?e=2891609", False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
sResponse = StrConv(.responseBody, vbUnicode)
End With
html.body.innerHTML = sResponse
With html
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1) = .querySelector(".company_name").innerText
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
clipboard.SetText .querySelector(".InputTable2").outerHTML
clipboard.PutInClipboard
End With
ThisWorkbook.Worksheets("Sheet1").Cells(2, 1).PasteSpecial
End Sub
Try it this way.
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 "http://www.bursamalaysia.com/market/listed-companies/company-announcements/5923061"
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

Parsing HTML getElementsByTagName not returning all cells

I have some code that use to work to scrape data from a webpage however the webpage has changed and can no longer get it to work. The code is supposed to do calculations on the insider transaction table however getelementsbytagname("td") no longer returns all cells.
I'm guessing it's because it is a page embedded in a page or something but I cannot for the life of me resolve it, I am not very familiar with html. A sample webpage is gurufocus.com/stock/lmb/insider.
My code is below:
Sub getStatements()
Dim wb As Object
Dim doc As Object
Dim incomeStmtURLs As Variant
Dim sURL As String
Dim allCells As IHTMLElementCollection
Dim aCell As HTMLTableCell
Dim i As Integer
Dim loginBoxData As String
Application.DisplayAlerts = False
Call ToggleEvents(False)
incomeStmtURLs = Range("Sheet1!h1:h2").Value
For i = 1 To UBound(incomeStmtURLs)
Set wb = CreateObject("internetExplorer.Application")
sURL = incomeStmtURLs(i, 1)
wb.navigate sURL
wb.Visible = False
While wb.Busy
Application.Wait Now + #12:00:01 AM#
DoEvents
Wend
'HTML document
Set doc = wb.document
On Error GoTo err_clear
' gets all cell and looks for date format,
' goes from new transaction to old so once gets to older than a year it exits for loop
' checks nextSibling from date is a buy and if so does calculations, by taking further value sin row
' for priceThisTime have to get rid of $ symbol for calculation
Set allCells = doc.getElementsByTagName("td")
For Each aCell In allCells
MsgBox (aCell.innerText)
If aCell.innerText Like "####-##-##" = True Then
If CDate(aCell.innerText) >= Date - 365 Then
If aCell.NextSibling.innerText = "Buy" Then
buys = buys + 1
sharesThisTime = CDec(aCell.NextSibling.NextSibling.innerText)
priceThisTime = aCell.NextSibling.NextSibling.NextSibling.NextSibling.innerText
totalPrice = totalPrice + (sharesThisTime * CDec(Right(priceThisTime, Len(priceThisTime) - 1)))
shareCount = shareCount + sharesThisTime
End If
Else
Exit For
End If
End If
Next aCell
Sheet6.Cells(i + 1, 2) = buys
If (shareCount <> 0) Then
Sheet6.Cells(i + 1, 3).Value = totalPrice / shareCount
End If
buys = 0
totalPrice = 0
shareCount = 0
err_clear:
If Err <> 0 Then
Err.Clear
Resume Next
End If
wb.Quit
Next i
Call ToggleEvents(True)
End Sub
The following targets specifically that table and retrieves all td elements. I think your logic could probably be applied on a column number basis but anyway (just in case I set the table into a variable as well).
I set the results per page to 100 but you can comment out that line
Option Explicit
'VBE > Tools > References:
' Microsoft Internet Controls
Public Sub GetData()
Dim ie As New InternetExplorer, lastDropDrownItemIndex As Long, dropDown As Object, t As Date
Const MAX_WAIT_SEC As Long = 10
With ie
.Visible = True
.Navigate2 "https://www.gurufocus.com/stock/lmb/insider"
While .Busy Or .readyState < 4: DoEvents: Wend
t = Timer
Do
Set dropDown = .document.querySelectorAll(".el-dropdown-menu__item")
lastDropDrownItemIndex = dropDown.Length - 1
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While lastDropDrownItemIndex < 1
If dropDown.Length = 0 Then Exit Sub
dropDown.item(lastDropDrownItemIndex).Click 'comment me out if don't want 100 results per page
Dim tds As Object, table As Object
Set tds = .document.getElementsByClassName("data-table")(0).getElementsByTagName("td")
Set table = .document.getElementsByClassName("data-table")
Stop
.Quit
End With
End Sub

Cannot extract data from a span itemprop

I have the following to extract some prices and availabilities from a webpage. But I get Object Required at:
Set price = ie.Document.querySelector(".price-cont .final-price")
Why?
Sub getMetaDataInfo()
Dim ie As New InternetExplorer
Dim mylink As String
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wks As Worksheet
Dim lastrow As Integer
Set wks = wb.Sheets("Info")
Dim i As Integer
lastrow = wks.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastrow
mylink = wks.Cells([i], 2).Value
ie.Visible = False
ie.Navigate mylink
Do
DoEvents
Loop Until ie.ReadyState = READYSTATE_COMPLETE
Dim price As Object, availability As Object
Set price = ie.Document.querySelector(".price-cont .price")
wks.Cells(i, "C").Value = price.innerText
Set availability = ie.Document.querySelector(".inner-box-one .availability")
wks.Cells(i, "D").Value = availability.innerText
Next i
End Sub
I tried to insert the delay like the following
Sub getMetaDataInfo()
Dim IE As New InternetExplorer
Dim mylink As String
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wks As Worksheet
Dim lastrow As Integer
Set wks = wb.Sheets("Info")
Dim i As Integer
lastrow = wks.Cells(Rows.Count, "B").End(xlUp).Row
IE.Visible = True
For i = 2 To lastrow
mylink = wks.Cells(i, 2).Value
IE.Visible = False
IE.Navigate mylink
Dim price As Object, t As Date
Const MAX_WAIT_SEC As Long = 5
Dim price As Object, availability As Object
While IE.Busy Or IE.ReadyState < 4: DoEvents: Wend
t = Timer
Do
DoEvents
On Error Resume Next
Set price = IE.Document.querySelector(".price-cont .final-price")
wks.Cells(i, "C").Value = price.innerText
If Timer - t > MAX_WAIT_SEC Then Exit Do
On Error GoTo 0
Loop
If price Is Nothing Then Exit Sub
Next i
End Sub
My scenario is I login first to webpage manually I keep the IE window open I go to excel run macro but..
Hard to tell without seeing HTML/URL. Have you verified the selector is correct?
Otherwise, the main two things you can do now, in relation to allowing enough time for page to load, are:
1) Add a proper wait before attempting to select
While ie.Busy Or ie.readyState < 4: DoEvents: Wend
2) Try a timed loop to allow further load time
Option Explicit
Public Sub LoopUntilSet()
Dim price As Object, t As Date
Const MAX_WAIT_SEC As Long = 5
'your other code
While ie.Busy Or ie.readyState < 4: DoEvents: Wend
t = Timer
Do
DoEvents
On Error Resume Next
Set price = ie.document.querySelector(".price-cont .price")
If Timer - t > MAX_WAIT_SEC Then Exit Do
On Error GoTo 0
Loop
If price Is Nothing Then Exit Sub
'other code.....
End Sub
3) Remove the [] from around i

Excel VBA get data from webpage in enterprise network

I'am an entusiast with vba.
In my company we conect to internet throught a proxy .pac file.
I need to get the weather from accuweather.
With the help of what i read in web i managed to do something that works but outside the company, for example in my home.
This is the code that is called by a form where the user selects the city, month and year.
Option Explicit
Sub GetExchangeRates(city As String, FromCurrency As String, Amount As String)
Dim XMLPage As New MSXML2.XMLHTTP60
Dim htmldoc As New MSHTML.HTMLDocument
Dim URL As String
Dim cn As String
Dim m As Long
Dim y As Date
Dim dfr As String
Dim d_until As Date
Dim MonthNm As String
MonthNm = FromCurrency
m = Application.Evaluate("=MONTH(1&" & Chr(34) & MonthNm & Chr(34) & ")")
y = Amount
dfr = Format(DateSerial(y, m, 1), "m/d/yyyy")
If city = "leiria" Then cn = "273891"
If city = "lisbon" Then cn = "274087"
If city = "porto" Then cn = "275317"
If city = "faro" Then cn = "273190"
If city = "coimbra" Then cn = "272818"
On Error GoTo Error_Handler
URL = "https://www.accuweather.com/pt/pt/" & city & "/" & cn & "/" &
FromCurrency & "-weather/" & cn & "?monyr=" & dfr & "&view=table"
XMLPage.Open "GET", URL, False
XMLPage.send
htmldoc.body.innerHTML = XMLPage.responseText
ProcessHTMLPage htmldoc
Range("C1").Value = city
Range("D1").Value = Amount
Range("G2").Value = "Data"
Application.Run "FillRow"
Error_Handler_Exit:
On Error Resume Next
Exit Sub
Error_Handler:
MsgBox "Ocorreu um erro de rede." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: getOperatingSystem" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "Internet access error!"
Resume Error_Handler_Exit
End Sub
Private Sub OpenRatesForm()
RatesForm.Show
End Sub
Sub ProcessHTMLPage(HTMLPage As MSHTML.HTMLDocument)
Dim HTMLTable As MSHTML.IHTMLElement
Dim HTMLTAbles As MSHTML.IHTMLElementCollection
Dim HTMLRow As MSHTML.IHTMLElement
Dim HTMLCell As New MSHTML.HTMLDocument
Dim RowNum As Long, ColNum As Integer
Set HTMLTAbles = HTMLPage.getElementsByTagName("table")
For Each HTMLTable In HTMLTAbles
Debug.Print HTMLTable.className
Worksheets.Add
Range("A1").Value = HTMLTable.className
Range("B1").Value = Now
RowNum = 2
For Each HTMLRow In HTMLTable.getElementsByTagName("tr")
'Debug.Print vbTab & HTMLRow.innerText
ColNum = 1
For Each HTMLCell In HTMLRow.Children
Cells(RowNum, ColNum) = HTMLCell.innerText
ColNum = ColNum + 1
Next HTMLCell
'''' For Each HTMLCell In HTMLTable.getElementsByTagName("td")
RowNum = RowNum + 1
Next HTMLRow
Next HTMLTable
Set HTMLTAbles = Nothing
End Sub
If run this in company i get errors from access denied e others.
So I read more and find that doing this with ie could work.
It bypasses the issue with acessing to internet, but the issue is that i cant get do make to work with the form and sometimes the ie opens with the accuweather page but does not displays data in excel.
Sub Grabaccuwther()
Dim objIE As InternetExplorer
Dim ele As Object
Dim y As Integer
Dim url As String
'start a new browser instance
Set objIE = CreateObject("InternetExplorer.Application")
'make browser visible
objIE.Visible = True
url = "https://www.accuweather.com/en/pt/lisbon/274087/november-weather/274087?monyr=11/1/2018&view=table"
'navigate to page with needed data
objIE.navigate url
'wait for page to load
Application.StatusBar = "Loading Web page …"
' wait until the page loads before doing anything
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
'we will output data to excel, starting on row 1
y = 1
For Each ele In objIE.Document.getElementsByTagName("tr")
'each 'tr' (table row) element contains 4 children ('td') elements
'put text of 1st 'td' in col A
Sheets("Sheet1").Range("A" & y).Value = ele.Children(0).textContent
'put text of 2nd 'td' in col B
Sheets("Sheet1").Range("B" & y).Value = ele.Children(1).textContent
'put text of 3rd 'td' in col C
Sheets("Sheet1").Range("B" & y).Value = ele.Children(2).textContent
'put text of 4th 'td' in col D
Sheets("Sheet1").Range("D" & y).Value = ele.Children(3).textContent
'increment row counter by 1
y = y + 1
Next
Application.StatusBar = "Web page Loaded!"
objIE.Quit
End Sub
I'm trying about a month do do this and I have changed some thinks but can't get this to work.
I aprreciate help to acomplish this.
Thanks.
This is based on you saying IE can generally access the page (also ensure the site is whitelisted.)
Whole table:
Option Explicit
Public Sub GetTable()
Dim IE As New InternetExplorer, hTable As HTMLTable
Dim ws As Worksheet, t As Date
Const MAX_WAIT_SEC As Long = 5
Set ws = ThisWorkbook.Worksheets("Sheet1")
With IE
.Visible = True
.navigate "https://www.accuweather.com/en/pt/lisbon/274087/november-weather/274087?monyr=11/1/2018&view=table"
While .Busy Or .readyState < 4: DoEvents: Wend
With .document
t = Timer
Do
DoEvents
On Error Resume Next
Set hTable = .querySelector(".calendar-list")
On Error GoTo 0
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While hTable Is Nothing
If Not hTable Is Nothing Then
Dim clipboard As Object
Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
clipboard.SetText hTable.outerHTML
clipboard.PutInClipboard
ws.Cells(1, 1).PasteSpecial
End If
End With
.Quit
End With
End Sub
Just the two columns you mention in comments:
Option Explicit
Public Sub GetTable()
Dim IE As New InternetExplorer, hTable As HTMLTable
Dim ws As Worksheet, t As Date, r As Long, c As Long, i As Long, j As Long
Const MAX_WAIT_SEC As Long = 5
Set ws = ThisWorkbook.Worksheets("Sheet1")
With IE
.Visible = True
.navigate "https://www.accuweather.com/en/pt/lisbon/274087/november-weather/274087?monyr=11/1/2018&view=table"
While .Busy Or .readyState < 4: DoEvents: Wend
With .document
t = Timer
Do
DoEvents
On Error Resume Next
Set hTable = .querySelector(".calendar-list")
On Error GoTo 0
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While hTable Is Nothing
If Not hTable Is Nothing Then
For i = 1 To hTable.getElementsByTagName("tr").Length - 1
r = r + 1
ws.Cells(r, 1) = hTable.getElementsByTagName("th")(i).innerText
ws.Cells(r, 2) = hTable.getElementsByTagName("tr")(i).getElementsByTagName("td")(0).innerText
Next
End If
End With
.Quit
End With
End Sub
References (VBE > Tools > References):
Microsoft Internet Controls
Microsoft HTML Object Library

Get HTML Element index number?

I'm trying to write something that pulls the .innerText from an HTML element. Here's my applicable code:
Sub test()
Dim URL = "https:// ** the website **"
Dim TDelements As IHTMLElementCollection, TDElementsRef As IHTMLElementCollection
Set IE = New InternetExplorer
With IE
.Navigate URL
.Visible = True
' Wait for the page to load
While .Busy Or .READYSTATE <> 4: DoEvents: Wend
Set HTMLdoc = .Document
End With
Set TDelements = HTMLdoc.getElementsByTagName("td")
Set TDElementsRef = HTMLdoc.getElementsByClassName("tdData")
r = 0
For Each TDelement In TDElementsRef
If bGetNext Then
Range("A1").Offset(r - 1, 1).Value = TDelement.innerText
bGetNext = False
End If
Debug.Print TDelement.innerText
If TDelement.className = "tdTitle" Then
If TDelement Then
Range("A1").Offset(r + 1, 0).Value = TDelement(2).innerText
bGetNext = True 'Trigger to get the information from the next TDelement
r = r + 1
End If
End If
Next
End sub
This will loop through all the info in between the <td> tags in the HTML. How though, do I ask VB what INDEX I'm currently at? I tried doing (just after the two Debug.Print lines) Debug.Print TDelement.Index but of course that's not right. How do I get the index of each TDelement??
The HTML looks like this:
and I just need to get the info in Green.
You've declared TDelementsRef as a Collection, but you're trying to set it to a single element.
If you only want to get the value of a single specific td element then:
Dim tdVal as String
tdVal = Document.getElementByClassName("tdData")(3).innerText
should do what you need.

Resources