VBA : Table capture from website

[ssingh75]

Hi All,

I am looking the below things from the website
http://www.camsonline.com/InvestorServices/COL_ISNAVLatest.aspx?amc=B

Input no. of days in text box
Click on the button.
wait till page gets loded.
Copy the below table

Dim strTempName As String
Dim strUser, strPass As String
Dim strURL, strURL1, Strhtml As String
Dim iDays, i, iRow, iCol, iSheets As Integer
Dim l, lRow, lCol, lSheets As Long
Dim strWindow1, strWindow2, strWindow3 As String
Dim ie, ie2, Shell As Object
Dim ie1 As SHDocVw.InternetExplorer
Dim htmlInput As MSHTML.HTMLInputElement
Dim htmlColl As MSHTML.IHTMLElementCollection
Dim objTag As IHTMLElement
Dim strName As String
Dim strActivity, strSubActivity As String
Dim iSelect1, iSelect2 As Integer

On Error Resume Next

strTempName = ActiveWorkbook.Name
iDays = Trim(Range("D1").Value)
Set Shell = CreateObject("Shell.Application")
Set ie = CreateObject("InternetExplorer.Application")
Set ie2 = CreateObject("InternetExplorer.Application")

'Assign User and password for login
Sheets(1).Activate
'Clear existing data
Range("A2:B1000").Select
Selection.ClearContents
Range("A1").Select

'Select Id and pass

strURL = "Computer Age Management Services"


' UserForm1.WebBrowser1.navigate strURL
ie.navigate strURL

apiShowWindow ie.hwnd, SW_MAXIMIZE

delay 10

'Navigate URL to capture the scheme URL
Strhtml = ie.document.DocumentElement.innerHTML
bunch = GetText2(Strhtml, "<TBODY>", "</TBODY>")
i = InStr(bunch, "</TR>")
For iRow = 0 To i
bunch1 = Trim(Replace(Split(bunch, "</TR>")(iRow), ",", ""))

'Get Scheme

bunch2 = Trim(Replace(Split(bunch1, "<TD>")(1), ",", ""))
bunch3 = Trim(Replace(Split(bunch2, "</TD>")(0), ",", "")) 'Scheme Name

'Get URL

bunch4 = Trim(Replace(Split(bunch1, "</A>")(0), ",", ""))
bunch5 = Trim(Replace(Split(bunch4, "href=")(1), ",", ""))
bunch6 = Trim(Replace(Split(bunch5, ">")(0), ",", ""))
bunch7 = Replace(bunch6, """", "")
bunch8 = "http://www.camsonline.com/InvestorServices/" & bunch7 'NAV URL

iCol = Application.WorksheetFunction.CountA(Range("A:A"))

iSheets = iCol + 1

'Populate Scheme Name
Range("A" & iSheets).Formula = Trim(bunch3)
Range("B" & iSheets).Formula = Trim(bunch8)

Next
Range("A:B").Select
Selection.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

ie.Quit

l = Application.WorksheetFunction.CountA(Range("B:B"))
Range("B1").Select
For lRow = 1 To l

strURL = Trim(ActiveCell.Offset(lRow, 0).Text)
ie2.navigate strURL
lCol = 1
apiShowWindow ie2.hwnd, SW_MAXIMIZE
delay 20


While lCol <> iDays
ie2.document.getElementById("txtUsername").Value = strUser
delay 10
'Click on Sign in button
ie2.document.forms(0).submit
delay 20

Wend
ie2.Quit
ie2 = ""
Next

 

[ssingh75]

Hi All,

I've written the below code to input number in text box and click on the submit button.Its working fine....

But, i am not able to get the table in excel sheet.

pls review the code and let me know if you can help..

Dim strTempName As String
Dim strUser, strPass As String
Dim strURL, strURL1, Strhtml As String
Dim iDays, i, iRow, iCol, iSheets As Integer
Dim l, lRow, lCol, lSheets, lText As Long
Dim strWindow1, strWindow2, strWindow3 As String
Dim ie, ie2, Shell, objWSHShell, objCollection, objElement As Object
Dim ie1 As SHDocVw.InternetExplorer
Dim htmlInput As MSHTML.HTMLInputElement
Dim htmlColl As MSHTML.IHTMLElementCollection
Dim objTag As IHTMLElement
Dim strName As String
Dim strActivity, strSubActivity As String
Dim iSelect1, iSelect2 As Integer

On Error Resume Next

strTempName = ActiveWorkbook.Name
iDays = Trim(Range("D1").Value)
Set Shell = CreateObject("Shell.Application")
Set ie = CreateObject("InternetExplorer.Application")
Set ie2 = CreateObject("InternetExplorer.Application")
Set objWSHShell = WScript.CreateObject("WScript.Shell")

'Assign User and password for login
Sheets(1).Activate
'Clear existing data
Range("A2:B1000").Select
Selection.ClearContents
Range("A1").Select

'Select Id and pass

strURL = "Computer Age Management Services"


' UserForm1.WebBrowser1.navigate strURL
ie.navigate strURL

While ie.readyState = READYSTATE_LOADING
delay 2.5
Wend
apiShowWindow ie.hwnd, SW_MAXIMIZE

delay 10

'Navigate URL to capture the scheme URL
Strhtml = ie.document.DocumentElement.innerHTML
bunch = GetText2(Strhtml, "<TBODY>", "</TBODY>")
i = InStr(bunch, "</TR>")
For iRow = 0 To i
bunch1 = Trim(Replace(Split(bunch, "</TR>")(iRow), ",", ""))

'Get Scheme

bunch2 = Trim(Replace(Split(bunch1, "<TD>")(1), ",", ""))
bunch3 = Trim(Replace(Split(bunch2, "</TD>")(0), ",", "")) 'Scheme Name

'Get URL

bunch4 = Trim(Replace(Split(bunch1, "</A>")(0), ",", ""))
bunch5 = Trim(Replace(Split(bunch4, "href=")(1), ",", ""))
bunch6 = Trim(Replace(Split(bunch5, ">")(0), ",", ""))
bunch7 = Replace(bunch6, """", "")
bunch8 = "http://www.camsonline.com/InvestorServices/" & bunch7 'NAV URL

iCol = Application.WorksheetFunction.CountA(Range("A:A"))

iSheets = iCol + 1

'Populate Scheme Name
Range("A" & iSheets).Formula = Trim(bunch3)
Range("B" & iSheets).Formula = Trim(bunch8)

Next
Range("A:B").Select
Selection.RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

ie.Quit

l = Application.WorksheetFunction.CountA(Range("B:B"))
Range("B1").Select
For lRow = 1 To l

strURL = Trim(ActiveCell.Offset(lRow, 0).Text)

ie2.navigate strURL
delay 2
While ie2.readyState = READYSTATE_LOADING
delay 2.5
Wend
lCol = 1
apiShowWindow ie2.hwnd, SW_MAXIMIZE

delay 5

Set objCollection = ie2.document.getElementsByTagName("input")

While lCol <> iDays

For lText = 0 To objCollection.Length
If objCollection(lText).Name = "sch_date" Then

' Set text for search
objCollection(lText).Value = lCol

Else
' If objCollection(lText).Type = "submit" And _
objCollection(lText).Name = "" Then
If objCollection(lText).Type = "submit" Then
' "Search" button is found
Set objElement = objCollection(lText)

End If
End If
Next

objElement.Click

Do While ie2.Busy = True
DoEvents
Loop

' While ie2.readyState = READYSTATE_LOADING
' delay 2.5
' Wend

delay 15

Wend
ie2.Quit
Set ie2 = Nothing

Next