Passing Value to Function to lookup web site - excel

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

Related

Get URL of the image that is the first result in google images

I have multiple keywords in an excel file, I am looking for a way to get the image URL of the first google image result on another cell in this excel file,
For Example
if my cell A1 contains "tomato"
I want cell A2 to display "https://seeds-gallery.com/4963-large_default/novosadski-jabucar-tomato-450-seeds.jpg" which is the image URL of the first result that shows up on Google Images
Can someone please help me out
You could do that in VBA using something like the following;
Public Sub InsertPicturesFromWeb()
Dim IE As InternetExplorer
Dim HTMLdoc As HTMLDocument
Dim imgElements As IHTMLElementCollection
Dim imgElement As HTMLImg
Dim aElement As HTMLAnchorElement
Dim N As Integer, I As Integer
Dim Url As String, Url2 As String
Dim LastRow As Long
Dim M, sImageSearchString
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To LastRow
Url = "https://www.google.co.in/search?q=" & Cells(I, 1) & "&source=lnms&tbm=isch&sa=X&rnd=1"
Set IE = New InternetExplorer
With IE
.Visible = False
.Navigate Url
Do Until .readyState = 4: DoEvents: Loop
Set HTMLdoc = .document
Set imgElements = HTMLdoc.getElementsByTagName("IMG")
N = 1
For Each imgElement In imgElements
If InStr(imgElement.src, sImageSearchString) Then
If imgElement.ParentNode.nodeName = "A" Then
Set aElement = imgElement.ParentNode
Url2 = imgElement.src
N = N + 1
End If
End If
Next
Call GetShapeFromWeb(Url2, Cells(I, 2))
IE.Quit
Set IE = Nothing
End With
Next I
End Sub
Sub GetShapeFromWeb(strShpUrl As String, rngTarget As Range)
With rngTarget.Parent
.Pictures.Insert strShpUrl
.Shapes(.Shapes.Count).Left = rngTarget.Left
.Shapes(.Shapes.Count).Top = rngTarget.Top
End With
End Sub

Google Translate text only if it is not english

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

Getting error 91 "Object variable or with block variable not set"

Running the below code throws error 91. What is wrong with it?
Sub abc()
Dim objIE As InternetExplorer
Set objIE = New InternetExplorer
Dim elem As HTMLBaseElement
objIE.Visible = True
objIE.navigate "https://www.nseindia.com/live_market/dynaContent/live_watch/get_quote/GetQuote.jsp?symbol=COALINDIA"
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
Set elem = getXPathElement("/html[1]/body[1]/div[2]/div[4]/div[2]/div[1]/div[4]/ul[1]/li[1]/span[1]", objIE.document)
Range("A5").Value = elem.innerText
End Sub
Public Function getXPathElement(sXPath As String, objElement As HTMLBaseElement) As HTMLBaseElement
Dim sXPathArray() As String
Dim sNodeName As String
Dim sNodeNameIndex As String
Dim sRestOfXPath As String
Dim lNodeIndex As Long
Dim lCount As Long
' Split the xpath statement
sXPathArray = Split(sXPath, "/")
sNodeNameIndex = sXPathArray(1)
If Not InStr(sNodeNameIndex, "[") > 0 Then
sNodeName = sNodeNameIndex
lNodeIndex = 1
Else
sXPathArray = Split(sNodeNameIndex, "[")
sNodeName = sXPathArray(0)
lNodeIndex = CLng(Left(sXPathArray(1), Len(sXPathArray(1)) - 1))
End If
sRestOfXPath = Right(sXPath, Len(sXPath) - (Len(sNodeNameIndex) + 1))
Set getXPathElement = Nothing
For lCount = 0 To objElement.ChildNodes().Length - 1
If UCase(objElement.ChildNodes().Item(lCount).nodeName) = UCase(sNodeName) Then
If lNodeIndex = 1 Then
If sRestOfXPath = "" Then
Set getXPathElement = objElement.ChildNodes().Item(lCount)
Else
Set getXPathElement = getXPathElement(sRestOfXPath, objElement.ChildNodes().Item(lCount))
End If
End If
lNodeIndex = lNodeIndex - 1
End If
Next lCount
End Function
That element has an id you can use instead
Option Explicit
Public Sub abc()
Dim objIE As InternetExplorer, elem As HTMLBaseElement
Set objIE = New InternetExplorer
objIE.Visible = True
objIE.navigate "https://www.nseindia.com/live_market/dynaContent/live_watch/get_quote/GetQuote.jsp?symbol=COALINDIA"
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop
Set elem = objIE.document.getElementById("lastPrice")
Debug.Print elem.innerText
ThisWorkbook.Worksheets("Sheet1").Range("A5").Value = elem.innerText
objIE.Quit
End Sub
I am guessing getXPathElement is a custom function? There isn't a native XPath selector method. If so, include the function in your question if you must have a solution using that function.

Use a loop to auto search

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

Get href value from speicific class in vba

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

Resources