I have a code to import HTML data from a website.
It works for importing data up to 94 Excel rows. After that it gives error
VBA Procedure too large.
I repeat the code started from ieApp.Navigate "https://icms.indianrail.gov.in/reports/ReportServlet?reportAction=Utility&reportType=LocoCurrStatus&subAction=main to End If for each row.
How do I modify the code for more than 600 rows?
Sub GetTable()
Dim ieApp As InternetExplorer
Dim ieDoc As Object
Dim ieTable As Object
Dim clip As DataObject
'create a new instance of ie
Set ieApp = New InternetExplorer
'you don’t need this, but it’s good for debugging
ieApp.Visible = True
'assume we’re not logged in and just go directly to the login page
ieApp.Navigate "https://icms.indianrail.gov.in/reports/"
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
Set ieDoc = ieApp.Document
'fill in the login form – View Source from your browser to get the control names
With ieDoc.forms(0)
.UserId.Value = "88888"
.Password.Value = "******"
.submit
End With
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
'now that we’re in, go to the page we want
ieApp.Navigate "https://icms.indianrail.gov.in/reports/ReportServlet?
reportAction=Utility&reportType=LocoCurrStatus&subAction=main"
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
'get the table based on the table’s id
Set ieDoc = ieApp.Document
With ieDoc.forms(0)
.trainNo.Value = Sheets("sheet1").Range("B2").Value
.startDate.Value = Format(Date - 1, "dd-mmm-yyyy")
.submit
End With
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
Set ieDoc = ieApp.Document
Set ieTable = ieDoc.all.Item("TABLE_6")
'copy the tables html to the clipboard and paste to teh sheet
If Not ieTable Is Nothing Then
Set clip = New DataObject
clip.SetText "" & ieTable.outerHTML & ""
clip.PutInClipboard
Sheet1.Select
Sheet1.Range("D2").Select
Sheet1.PasteSpecial "Unicode Text"
End If
End Sub
My Excel Sheet:
Related
Is a long time ago to programming VBA. I want to fetch in a web Table all Linked PDF Files in coll um (x). First I have created the logins and navigate to the site to fetch file.
Site table:
Sub goToShopWH()
Dim ieApp As InternetExplorer
Dim ieDoc As Object
Dim clip As Object
'Table Grapping
Dim ieTable As Object
'create a new instance of ie
'Set ieApp = New InternetExplorer
Set ieApp = CreateObject("InternetExplorer.Application")
'you don’t need this, but it’s good for debugging
ieApp.Visible = True
'assume we’re not logged in and just go directly to the login page
ieApp.Navigate "https://website.com/ishop/Home.html"
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents:
Loop
' Login to site
Set ieDoc = ieApp.Document
'fill in the login form – View Source from your browser to get the control names
With ieDoc '.forms("loginForm_0")
.getElementById("loginField").Value = "username"
.getElementById("password").Value = "Password"
.getElementById("loginSubmit").Click
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
'now that we’re in, go to the page we want
'Switsh to search form
ieApp.Navigate "https://website.com/ishop/account/MyAccount,$comp$account$AccountNavigation.orderHistory.sdirect?sp=Saccount%2FOrderHistory"
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
' fillout form
Set ieDoc = ieApp.Document
With ieDoc '.forms("Form_0")
.getElementById("PropertySelection_2").Value = "7"
.getElementById("commtxt").Value = "190055" 'Projekt Nummer oder Text.
.getElementById("Submit_0").Click
End With
Do
DoEvents
Loop Until ieApp.ReadyState = 4
Application.Wait Now + TimeSerial(0, 0, 5)
With ieDoc '.forms("Form_1")
.getElementById("PropertySelection").Value = "3"
.getElementById("PropertySelection").FireEvent ("onchange")
End With
Do
DoEvents
Loop Until ieApp.ReadyState = 4
Application.Wait Now + TimeSerial(0, 0, 5)
End With
Set webpage = ieApp.Document
Set table_data = webpage.getElementsByTagName("tr")
End Sub
Please help my to solve this to get I want import Table to sheet2 and download all PDF in ("Table"),("tbody")(tr)(1 to X),(td)(10),(href).click
I think you are after something like this.
Sub webpage()
Dim internet As Object
Dim internetdata As Object
Dim div_result As Object
Dim header_links As Object
Dim link As Object
Dim URL As String
Set internet = CreateObject("InternetExplorer.Application")
internet.Visible = True
URL = "https://www.google.co.in/search?q=how+to+program+in+vba"
internet.Navigate URL
Do Until internet.ReadyState >= 4
DoEvents
Loop
Application.Wait Now + TimeSerial(0, 0, 5)
Set internetdata = internet.Document
Set div_result = internetdata.getelementbyid("res")
Set header_links = div_result.getelementsbytagname("h3")
For Each h In header_links
Set link = h.ChildNodes.Item(0)
Cells(Range("A" & Rows.Count).End(xlUp).Row + 1, 1) = link.href
Next
MsgBox "done"
End Sub
Or, perhaps this.
' place your URL in cell L1
Sub HREF_Web()
Dim doc As HTMLDocument
Dim output As Object
Set IE = New InternetExplorer
IE.Visible = False
IE.navigate Range("L1")
Do
'DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Set doc = IE.document
Set output = doc.getElementsByTagName("a")
i = 5
For Each link In output
'If link.InnerHTML = "" Then
Range("A" & i).Value2 = link
' End If
i = i + 1
Next
MsgBox "Done!"
End Sub
I've created this code that simulates my actual application. And I'm trying to run the procedure through WebBrowser1. If in my actual application it was possible to use .document.getElementById would work, but you need .getElementsByClassName or TagName. How could I do this with the data below?
The code application is executed by the CommandButton and the WebBrowser will be inside a Userform.
Private Sub CommandButton1_Click()
Dim IE As InternetExplorer
Dim iELE As Object
Dim xUser As String
Dim xPswd As String
Set IE = New InternetExplorer
IE.Visible = True
IE.Navigate ("https://twitter.com/login?lang=pt")
xUser = "your username"
xPswd = "your password"
Application.Wait (Now + TimeValue("0:00:10"))
Do While IE.Busy = True Or IE.ReadyState <> 4: DoEvents: Loop
For Each iELE In IE.Document.getElementsByClassName("js-username-field email-input js-initial-focus")
If iELE.Value = "" Then
iELE.Value = xUser
End If
Exit For
Next
For Each iELE In IE.Document.getElementsByClassName("js-password-field")
If iELE.Value = "" Then
iELE.Value = xPswd
End If
Exit For
Next
Application.Wait (Now + TimeValue("0:00:05"))
For Each iELE In IE.Document.getElementsByClassName("submit EdgeButton EdgeButton--primary EdgeButtom--medium")
If iELE.Value = "" Then
iELE.Click
End If
Exit For
Next
End Sub
Try this
Sub Login(MyLogin, MyPass, strUrl)
Dim IeApp As InternetExplorer
Dim IeDoc As Object
Dim ieTable As Object
Set IeApp = New InternetExplorer
IeApp.Visible = False
IeApp.Navigate strUrl
Do While IeApp.Busy: DoEvents: Loop
Do Until IeApp.readyState = READYSTATE_COMPLETE: DoEvents: Loop
Set IeDoc = IeApp.Document
With IeDoc
.getElementsByClassName("js-username-field")(0).value = MyLogin
.getElementsByClassName("js-password-field")(0).value = MyPass
End With
IeDoc.getElementsByClassName("submit")(0).Click
Do While IeApp.Busy: DoEvents: Loop
Do Until IeApp.readyState = READYSTATE_COMPLETE: DoEvents: Loop
End Sub
https://www.pk-anexcelexpert.com/vba-web-browser-in-the-user-form/
I want to add value in web page text box but getting object error.
I can't provide url as it will not work outside the office.
below html code:text box :
<input type="text" size="40" name="agent" id="go" value="">
Search :
<button type="submit">Submit</button>
VBA:
Sub login_page()
Dim ieApp As SHDocVw.InternetExplorer
Dim iedoc As MSHTML.HTMLDocument
IEApp.Visible = True
Set ieApp = New SHDocVw.InternetExplorer
ieApp.Visible = True
ieApp.navigate "http:/Login"
Do While ieApp.Busy: DoEvents: Loop
Do Until ieApp.readyState = READYSTATE_COMPLETE: DoEvents: Loop
Set iedoc = ieApp.document
with iedoc.forms(0)
.user.Value = "id"
.Password.Value = "Pass"
.submit
End With
ieApp.navigate "http:action=view"
Do While ieApp.Busy: DoEvents: Loop
'Do Until ieApp.readyState = READYSTATE_COMPLETE: DoEvents: Loop
ieApp.navigate "http:action=run"
Do While ieApp.Busy: DoEvents: Loop
ieApp.navigate "http:Report?"
action=run&category=interfaces&template=base%2Frouterprotocols§ion=5"
Do While ieApp.Busy: DoEvents: Loop
ieApp.document.parentWindow.execScript "window.location='Go?action=agent'"
End Sub
There is an id so use it
ieApp.document.getElementById("go")
Preceeding code
Dim ieApp As InternetExplorer
Set ieApp = New InternetExplorer
With ieApp
.Visible = True
.Navigate2 "URL"
While .Busy Or .readyState < 4: DoEvents: Wend
.document.getElementById("go").value = "xyz"
End With
let me help you.
Dim ie As New InternetExplorer
Dim elemnts As Object
Dim elem As Object
ie.Navigate url
Do While ie.ReadyState = 4: DoEvents: Loop 'Do While.
Do Until ie.ReadyState >= 3: DoEvents: Call aceitaAlerta(False): Loop 'Do Until
Set ELEMENTS = ie.Document.all
For Each elem In ELEMENTS
on error goto NextOne
If elem.name = "agente" And elem.id = "go" Then
elem.Value = "NEWVALUE"
elem.innerText = "NEWVALUE"
Exit For
End If
NextOne:
on error goto 0
Next elem
I have below code, which fetch data from a Intranet. But its taking more time to fetch data.can someone help me to modify the code to increase the performance.
Thanks In Advance
Note-I haven't posted URL as it is clients website. Sorry about that.
Sub FetchData()
Dim IE As Object
Dim Doc As HTMLDocument
Dim myStr As String
On Error Resume Next
Set IE = CreateObject("InternetExplorer.Application") 'SetBrowser
IE.Visible = False
IE.navigate "URL" 'Open website
Do While IE.Busy Or IE.ReadyState <> 4
Application.Wait DateAdd("s", 1, Now)
Loop
Set Doc = IE.Document
Doc.getElementById("tbxUserID").Value = InputBox("Please Enter Your ID")
Doc.getElementById("txtPassword").Value = InputBox("Please Enter Your
Password")
Doc.getElementById("BtnLogin").Click
Do While IE.Busy Or IE.ReadyState <> 4
Application.Wait DateAdd("s", 1, Now)
Loop
IE.navigate "URL"
Do While IE.Busy Or IE.ReadyState <> 4
Application.Wait DateAdd("s", 1, Now)
Loop
Dim LastRow As Long
Set wks = ActiveSheet
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowNo = wks.Range("A1:A" & LastRow)
For rowNo = 2 To LastRow
Doc.getElementById("txtField1").Value =
ThisWorkbook.Sheets("Sheet1").Range("A" & rowNo).Value
Doc.getElementById("CtrlQuickSearch1_imgBtnSumbit").Click
Do While IE.Busy Or IE.ReadyState <> 4
Application.Wait DateAdd("s", 1, Now)
Loop
strVal1 = Doc.querySelectorAll("span")(33).innerText
ThisWorkbook.Sheets("Sheet1").Range("B" & rowNo).Value = strVal1
strVal2 = Doc.querySelectorAll("span")(35).innerText
ThisWorkbook.Sheets("Sheet1").Range("C" & rowNo).Value = strVal2
Next
End Sub
Can't guarantee this will run. Points to note:
Use of Worksheets collection
Use of Option Explicit - this means you then have to use the right datatype throughout. Currently you have undeclared variables and, for example, rowNo is used as a Long and as a range.
Removal of On Error Resume Next
Putting all worksheets into variables
Placement of values into array and looping array to get id values. Looping sheet is expensive
Use of early binding and adding class to InternetExplorer
Assumption that after login a new url present and that you need to navigate back to that before each new loop value
Removal of hungarian notation
Ids are fastest selector method so no improvement there
With your css type selectors, e.g. .document.querySelectorAll("span")(33), you might seek whether there is a single node short selector that can be used, rather than using nodeList
VBA:
Option Explicit
Public Sub FetchData()
Dim ie As Object, ie As InternetExplorer
Dim lastRow As Long, wks As Worksheet, i As Long, ws As Worksheet
Set ie = New SHDocVw.InternetExplorer 'SetBrowser
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set wks = ActiveSheet '<==use explicit sheet name if possible
lastRow = wks.Cells(wks.rows.Count, "A").End(xlUp).Row
loopvalues = Application.Transpose(wks.Range("A2:A" & lastRow).Value)
With ie
.Visible = False
.Navigate2 "URL" 'Open website
While .Busy Or .readyState < 4: DoEvents: Wend
.document.getElementById("tbxUserID").Value = InputBox("Please Enter Your ID")
.document.getElementById("txtPassword").Value = InputBox("Please Enter Your Password")
.document.getElementById("BtnLogin").Click
While .Busy Or ie.readyState < 4: DoEvents: Wend
Dim newURL As String, val1 As String, val2 As String
newURL = .document.URL
For i = LBound(loopvalues) To UBound(loopvalues)
.document.getElementById("txtField1").Value = loopvalues(i)
.document.getElementById("CtrlQuickSearch1_imgBtnSumbit").Click
While .Busy Or .readyState < 4: DoEvents: Wend
val1 = .document.querySelectorAll("span")(33).innerText
ws.Range("B" & i).Value = val1
val2 = .document.querySelectorAll("span")(35).innerText
ws.Range("C" & i).Value = val2
.Navigate2 newURL
While .Busy Or ie.readyState < 4: DoEvents: Wend
Next
.Quit
End With
End Sub
I have code to open IE, login with username/password, tick some checkboxes, click button and open a report on a pop up window.
I am trying to copy the content of the pop up window to an Excel sheet. The code that deals with the pop up window doesn't detect the url.
Sub MyRosterApps()
Dim MyHTML_Element As IHTMLElement
Dim HTMLdoc As HTMLDocument
Dim MyHTML_Element As IHTMLElement
Dim MyURL As String
Dim objIE As InternetExplorer, t As Date, nodeList As Object, i As Long
Dim ieIEWindow As SHDocVw.InternetExplorer
Dim y As Integer
Const MAX_WAIT_SEC As Long = 5
'Ignore Errors
On Error GoTo Err_Clear
MyURL = "Not a public URL"
Set MyBrowser = New InternetExplorer
MyBrowser.Silent = True
MyBrowser.navigate MyURL
MyBrowser.Visible = True
Do
'Wait till finished
Loop Until MyBrowser.readyState = READYSTATE_COMPLETE
Set HTMLdoc = MyBrowser.document
'Enter user / password
HTMLdoc.all.txtUsername.Value = "username" ' Eneter your email id here
HTMLdoc.all.txtPassword.Value = "password" 'Enter your password here
HTMLdoc.all.Item("btnLogin").Click
For Each MyHTML_Element In HTMLdoc.getElementsByName("btnLogin")
If MyHTML_Element.Type = "submit" Then MyHTML_Element.Click: Exit For
Next
Do
'Wait till finished
Loop Until MyBrowser.readyState = READYSTATE_COMPLETE
Set HTMLdoc = MyBrowser.document
HTMLdoc.all.Item("ucSkillsPicker_lstSkills_35").Click
HTMLdoc.all.Item("btnShowReport").Click
' The Pop Up windows opens
Do
Loop Until MyBrowser.readyState = READYSTATE_COMPLETE
Set HTMLdoc = MyBrowser.document
' Until here is works fine
' Trying to deal with the Pop Up windows
With objIE
.Visible = True
' I am trying to get the active window url which is the pop up
.navigate ieIEWindow.LocationURL
Do While .Busy = True Or .readyState <> 4: DoEvents: Loop
t = Timer
Do
DoEvents
On Error Resume Next
' Go thru DIV classes and find these two oReportCell .a71
Set nodeList = .document.querySelectorAll("#oReportCell .a71")
On Error GoTo 0
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While nodeList Is Nothing
If Not nodeList Is Nothing Then
'Paste the value found in DIV classes in Sheet1
With ThisWorkbook.Worksheets("Sheet1")
For i = 0 To nodeList.Length - 1
.Cells(1, i + 1) = nodeList.Item(i).innerText
Next
End With
End If
.Quit
End With
Err_Clear:
If Err <> 0 Then
'Debug.Assert Err = 0
Err.Clear
Resume Next
End If
End Sub
This code below is separate from above. If I run just like this it does what I need. Of course, I have to paste the targeted window url.
.navigate "url of the pop up window"
The issue is that the pop up window url expires or something like that.
After some time the page says that I have to go through selecting some check boxes and submit.
Option Explicit
Public Sub GrabLastNames()
Dim objIE As InternetExplorer, t As Date, nodeList As Object, i As Long
Const MAX_WAIT_SEC As Long = 5
Set objIE = New InternetExplorer
With objIE
.Visible = True
' Paste targeted window. In my case is the pop up window
.navigate "url of the pop up window"
Do While .Busy = True Or .readyState <> 4: DoEvents: Loop
t = Timer
Do
DoEvents
On Error Resume Next
Set nodeList = .document.querySelectorAll("#oReportCell .a71")
On Error GoTo 0
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While nodeList Is Nothing
If Not nodeList Is Nothing Then
With ThisWorkbook.Worksheets("Sheet3")
For i = 0 To nodeList.Length - 1
.Cells(1, i + 1) = nodeList.item(i).innerText
Next
End With
End If
.Quit
End With
End Sub