I made a code that can use the cell in A2 to search it in a specific website and pull down the criteria that I need. I'm having trouble making the correct loop for this. Can someone point me in the right direction? (cells from A2 to A1829)
Code:
Sub SearchBot()
Dim objIE As InternetExplorer
Dim aEle As HTMLLinkElement
Dim y As Integer
Dim result As String
Dim TR As Object, TD As Object
Dim tbl As Object, obj_tbl As Object
Dim lastRow As Long
Dim start_time As Date
Dim end_time As Date
Set objIE = New InternetExplorer
objIE.Visible = True 'make IE browser visible
objIE.navigate "https://capitaliq.com"
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
For i = 1 to 1829
objIE.document.getElementById("SearchTopBar").Value = _
Sheets("Sheet2").Range("A" & i).Value
Set oNode = objIE.document.getElementsByClassName("iPadHack tmbsearchright")(0)
oNode.Click
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
b = 2
Dim tblEle As Object
Set tblEle = objIE.document.getElementsByClassName("cTblListBody")(5)
Sheets("Sheet2").Range("B" & b).Value = tblEle.innerText
Debug.Print tblEle.innerText
b = b + 1
Next i
objIE.Quit
End Sub
you're not using the loop variable i anywhere, guessing it should be this line:
Sheets("Sheet2").Range("A").Value
change to:
Sheets("Sheet2").Range("A" & i).Value
Related
I am importing google alerts into my excel worksheet , what I am trying to do is only use the google translate code I have if the text is not in English. As the code is very slow. And I import upto 1000 rows of text. The majority of those are already in English. But at present my code translates every row.
Public Sub Translate()
Const MAX_WAIT_SEC As Long = 5
Dim IE As New InternetExplorer
Dim t As Date
Dim ws As Worksheet
Dim ftext As String
Dim x
Dim y As Long
Dim translation As Object
Dim translationText As String
y = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Set ws = ThisWorkbook.Worksheets("Google_Notifications")
For x = 1 To y
With IE
.Visible = False
.Navigate "https://translate.google.com/#view=home&op=translate&sl=auto&tl=en"
While .Busy Or .ReadyState < 4: DoEvents: Wend
ftext = Sheet1.Range("C" & x).Value
.Document.querySelector("#source").Value = ftext
While .Busy Or .ReadyState < 4: DoEvents: Wend
t = Timer
Do
On Error Resume Next
Set translation = .Document.querySelector(".tlid-translation.translation")
translationText = translation.textContent
On Error GoTo 0
If Timer - t > MAX_WAIT_SEC Then Exit Do
Loop While translationText = vbNullString
Sheet1.Range("C" & x).Value = translationText
Sheet1.Range("E" & x).Value = "Translated"
.Quit
Set IE = Nothing
Set translation = Nothing
translationText = ""
End With
Next x
End Sub
I'm getting error type mismatch on the rng.value under objie.document. What I wanted to do is to conduct Google news search based on the value of the defined range and loop through each cell.
Sub SearchBot()
Dim objie As InternetExplorer
Dim aEle As HTMLLinkElement
Dim y As Integer
Dim result As String
Dim form As Variant, button As Variant
Dim rng As Range
Dim i As Integer
Dim lastrow As Long
lastrow = Sheets("sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set objie = New InternetExplorer
Set rng = Range("A2:A" & lastrow)
user = Environ("username")
objie.Visible = True
For Each cell In rng
rng.Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
objie.Navigate "https://www.google.com.sg/search?q=(fraud)&tbm=nws&spf=1495542183367&cad=h"
Do While objie.Busy = True Or objie.ReadyState <> 4: DoEvents: Loop
objie.Document.getElementById("lst-ib").Value = _
rng.Value & " (fraud)"
Set form = objie.Document.body.getElementsByTagName("form")(0)
Set button = form.getElementsByTagName("button")(0)
button.Click
Do While objie.Busy = True Or objie.ReadyState <> 4: DoEvents: Loop
TimeOutWebQuery = 5
TimeOutTime = DateAdd("s", TimeOutWebQuery, Now)
Do Until objie.ReadyState = 4
DoEvents
If Now > TimeOutTime Then
objie.Stop
GoTo ErrorTimeOut
End If
Loop
objie.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
Call PDFPrint("C:\Users\" & user & "\Desktop\" & "Screening_" & rng.Value & " " & rng.Offset(0, 1).Value & ".pdf")
ErrorTimeOut:
Set objie = Nothing
Next cell
End Sub
rng.cells.Count is greater than one. That means you cannot access the property value of the range. You have to get at a single cell. You probably mean
objie.Document.getElementById("lst-ib").Value = _
cell.Value & " (fraud)"
I have made the macros script which retrieves the data from the URL. What I need is that, I need to increase the date one by one and get the data for each. the URL is like this :
https://www.ukdogracing.net/racecards/01-05-2017/monmore
Ia m able to get the data with this script :
Sub GetData()
Dim IE As Object
Dim doc As Object
Dim strURL As String
Dim I As Integer
For I = 1 To 5
strURL = "https://www.ukdogracing.net/racecards/01-05-2017/monmore" + Trim(Str(I))
Set IE = CreateObject("InternetExplorer.Application")
With IE
.navigate strURL
Do Until .ReadyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
Set doc = IE.Document
GetAllTables doc
.Quit
End With
Next I
End Sub
Sub GetAllTables(doc As Object)
Dim ws As Worksheet
Dim rng As Range
Dim tbl As Object
Dim rw As Object
Dim cl As Object
Dim tabno As Long
Dim nextrow As Long
Dim I As Long
Dim ThisLink As Object 'variable for <a> tags
Set ws = Worksheets.Add
For Each tbl In doc.getElementsByTagName("TABLE")
tabno = tabno + 1
nextrow = nextrow + 1
Set rng = ws.Range("B" & nextrow)
rng.Offset(, -1) = "Table " & tabno
For Each rw In tbl.Rows
For Each cl In rw.Cells
rng.Value = cl.outerText
Set rng = rng.Offset(, 1)
I = I + 1
Next cl
nextrow = nextrow + 1
Set rng = rng.Offset(1, -I)
I = 0
Next rw
Next tbl
I = Range("B" & Rows.Count).End(xlUp).Row 'last row with data
Do While Cells(I, 1).Value = "" 'will loop until first not blank found in column A (starting from last row of data, from end to start)
For Each ThisLink In doc.getElementsByTagName("a") 'we check all <a> tags
If ThisLink.innerText = Cells(I, 2).Value Then Cells(I, 1).Value = ThisLink.href 'If the innertext is the name of the race, in column A we add link
Next ThisLink
I = I - 1 'we decrease row position
Loop
End Sub
But I need the script takes the date part of the URL and add one day each time till today and get the data. for example :
https://www.ukdogracing.net/racecards/01-06-2017/monmore
https://www.ukdogracing.net/racecards/01-07-2017/monmore
etc... How can I make the script to get the data for each day adding one each time.
Thanks in advance.
Replace the first sub with this one and it will run for the specified dates. I couldn't see I having any purpose so i removed it.
Sub GetData()
Dim IE As Object, doc As Object
Dim strURL As String, myDate As Date
Set IE = CreateObject("InternetExplorer.Application")
With IE
For myDate = CDate("01-05-2017") To CDate("01-09-2017")
strURL = "https://www.ukdogracing.net/racecards/" & Format(myDate, "mm-dd-yyyy") & "/monmore" ' Trim(Str(I))
.navigate strURL
Do Until .ReadyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
Set doc = IE.Document
GetAllTables doc
Next myDate
.Quit
End With
End Sub
I'm trying to write a function to pass a values in Column A to the function, but can't seem to get the format correct.
Function GetClassNames(cell As Range) As Variant
Dim MyCell As String
MyCell = cell.value
objIE.navigate "www.mysite.com/archive.aspx?code=" & Range(MyCell).Text
Here is the working Subroutine
Sub GetNames()
Dim HTML As HTMLDocument
Dim objIE As Object
Dim y As Integer
Dim result As String
Set objIE = New InternetExplorer
objIE.Visible = True
objIE.navigate "https://www.cattle.com/markets/archive.aspx?code=" & Range("A1").Text
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
y = 2
Set HTML = objIE.document
Set elements = HTML.getElementsByClassName("list-group-item")
For Each element In elements
If element.className = "list-group-item" Then
Sheets("Sheet2").Cells(1, y).Value = element.innerText
Selection.NumberFormat = "yyyy-mm-dd"
y = y + 1
End If
Next element
End Sub
I made a code that will use the cells in column A and search it in a website and pull down a certain table I need. However, sometimes I get an error (because the name is wrong or whatever), and I want the code to skip it and move on.
Example: if searched A3 was a problem, and I want the code to search A4, etc.
The Error is Run-time error '91': object variable or With block variable not set
Code:
Sub SearchBot()
Dim objIE As InternetExplorer
Dim aEle As HTMLLinkElement
Dim y As Integer
Dim result As String
Dim tbl As Object, obj_tbl As Object
Dim lastRow As Long
Dim start_time As Date
Dim end_time As Date
Dim cookie As String
Dim result_cookie As String
Set objIE = New InternetExplorer
objIE.Visible = True
objIE.navigate "https://website.com"
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
For i = 2 To 1829
objIE.document.getElementById("SearchTopBar").Value = _
Sheets("Sheet2").Range("A" & i).Value '
Set oNode = objIE.document.getElementsByClassName("iPadHack tmbsearchright"
(0)
oNode.Click
On Error GoTo ErrorHandler
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
Dim tblEle As Object
Set tblEle = objIE.document.getElementsByClassName("cTblListBody")(5)
Sheets("Sheet2").Range("B" & i).Value = tblEle.innerText
Debug.Print tblEle.innerText
Next
ErrorHandler
Resume Next
objIE.Quit
End Sub
This can raise an error:
Set tblEle = objIE.document.getElementsByClassName("cTblListBody")(5)
For example, if no matching element with classname "cTblListBody" is found, or if there are fewer than 6 of those items found, etc. In this case, your error handler will take over, and the tblEle will be Nothing.
This statement Resume Next will attempt to resume execution on the next line (from the line which raised the error), and these lines will of course fail if the tblEle has not been assigned (i.e., Is Nothing).
Sheets("Sheet2").Range("B" & i).Value = tblEle.innerText
Debug.Print tblEle.innerText
You don't want to Resume Next, you want to resume at the next iteration of the loop, so you can do this with another label:
On Error GoTo ErrorHandler
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
Dim tblEle As Object
Set tblEle = objIE.document.getElementsByClassName("cTblListBody")(5)
Sheets("Sheet2").Range("B" & i).Value = tblEle.innerText
Debug.Print tblEle.innerText
NextItem:
Next
ErrorHandler
Resume NextItem
Or, more appropriately (IMHO), trap this error:
'## THIS LINE IS NOT NEEDED:
' On Error GoTo ErrorHandler
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
Dim tblEle As Object
Set tblEle = objIE.document.getElementsByClassName("cTblListBody")
If Not tblEle Is Nothing Then
If tblEle.length > 5 Then
Sheets("Sheet2").Range("B" & i).Value = tblEle(5).innerText
Debug.Print tblEle(5).innerText
End If
End If
Next
'## THESE ARE NOT NEEDED:
'ErrorHandler
'Resume NextItem
Note: this assumes that at least 6 cTblListBody are found, if that may not be the case, additional logic may be required.
use this:
Dim objIE As Object
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Top = 0
objIE.Left = 0
objIE.Width = 800
objIE.Height = 600
objIE.Visible = True