VBA program to get information from website not working 100%

[JohnPeter]

Hey,

I'm trying to create something in Excel so that we are able to know when our standards go out of date, as - for some unknown reason - this is not something that can be done online or via. a reliable service.

Essentially, I have column with standards, ie. AS_4021_1 and another column with the date of the standard, ie. 2018. My intentions are to run a macro in vba that will open IE, take the standard name and search it through '

https://infostore.saiglobal.com/en-au/Search/All/?searchTerm="STANDARD NAME HERE"', return the title of the first result from this webpage (which can be used to retrieve the year of the most current publication) and create a hyperlink.

From here I will be able to run the macro, see all publications which are supposedly out of date and follow the hyperlinks to see where either the macro has returned the wrong result, or our publication is out of date.

Currently I have; ​

    Dim cell As Range, Rng As Range

        Sheets("Check").Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row).Select

    For Each cell In Rng
        If cell.Hyperlinks.Count = 0 Then
            ActiveSheet.Hyperlinks.Add Anchor:=cell, _
               Address:="https://infostore.saiglobal.com/en-au/Search/All/?searchTerm=" & cell.Value
        End If
    Next

This just sets the range as all cells with a value in the standard name column, and creates the hyperlinks in these cells. (These cells are taken automatically from another worksheet). This part seems to work fine.​

    Dim IE As Object

    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False

  For Each cell In Rng
    
        With cell
            IE.navigate "https://infostore.saiglobal.com/en-au/Search/All/?searchTerm=" & cell.Value

            While IE.Busy
                DoEvents
            Wend
            
Application.Wait (Now + TimeValue("0:00:03"))

            cell.Offset(, 2) = IE.document.getElementsByClassName("product-item--body span10")(0).innerText
       End With
    Next
    
    
End Sub

This is where I am encountering two errors, the first being the '=IE.document.getElementsByClassName' which is giving me all of the innertext of "product-item--bodyspan10" when all i'm wanting is the AS"####-##" bit.

The second problem being I have to include the Application.wait as without this I seem to receive multiple of the same result (as i'm guessing IE just cannot keep up with the program, and the while IE.Busy doesn't seem to alleviate this problem.

Any help would be greatly appreciated,
Thanks

 

[Domenic]

Does this return the desired information?

[COLOR=#333333]cell.Offset(, 2) = [/COLOR]IE.document.getElementsByClassName("product-item--body span10")(0).getElementsByTagName("a")(0).innerText

 

[JohnPeter]

Does this return the desired information?

[COLOR=#333333]cell.Offset(, 2) = [/COLOR]IE.document.getElementsByClassName("product-item--body span10")(0).getElementsByTagName("a")(0).innerText

Yep, did a bit of googling and came up with

cell.Offset(, 2) = IE.document.getElementsByClassName("product-item--body span10")(0).firstElementChild.innerText

Which I think is the same thing, it's all working now but I would like to perhaps change the application.wait to a better method.

Thanks.

 

[Domenic]

Yep, did a bit of googling and came up with

cell.Offset(, 2) = IE.document.getElementsByClassName("product-item--body span10")(0).firstElementChild.innerText

Which I think is the same thing, it's all working now...

Yeah, that will do it as well.

...but I would like to perhaps change the application.wait to a better method.

With the following code, first it makes sure that the HTML document and specified element are available. Then, if for some reason it's taking too long to load a webpage and find the specified element, a message will pop up after the specified time (in seconds), asking whether you want to continue with the same item. If you answer yes, it will try again. If you answer no, it will proceed with the next item. And, if you answer cancel, it will abort the procedure altogether. As it stands, it is set to keep trying after 30 seconds has elapsed. You can change this as desired. Try it, and see know how it works out.

Option Explicit

Sub test()


    Dim IE As Object
    Dim HTMLDoc As Object
    Dim HTMLEle As Object
    Dim rCell As Range
    Dim Rng As Range
    Dim StartTime As Single
    Dim Counter As Long
    Dim Ans As Long
    
    Const SECONDS_TO_KEEP_TRYING As Long = 30 'change the duration as desired


    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = False
    
    Set Rng = Range("A2:A10") 'change accordingly


    On Error Resume Next
    For Each rCell In Rng
        If rCell.Value <> "" Then
            IE.navigate "https://infostore.saiglobal.com/en-au/Search/All/?searchTerm=" & rCell.Value
            While IE.Busy Or IE.ReadyState <> 4 'READYSTATE_COMPLETE
                DoEvents
            Wend
            StartTime = Timer
            Do
                If HTMLDoc Is Nothing Then
                    Set HTMLDoc = IE.document
                Else
                    Set HTMLEle = HTMLDoc.getElementsByClassName("product-item--body span10")(0).getElementsByTagName("a")(0)
                    If Not HTMLEle Is Nothing Then
                        rCell.Offset(, 2) = HTMLEle.innerText
                        Exit Do
                    End If
                End If
                If Timer - StartTime > SECONDS_TO_KEEP_TRYING Then
                    Ans = MsgBox("Continue searching for " & rCell.Value & "?", vbYesNoCancel, "Continue?")
                    If Ans = vbNo Then Exit Do
                    If Ans = vbCancel Then GoTo ExitTheSub
                    StartTime = Timer
                End If
            Loop
            Set HTMLDoc = Nothing
            Set HTMLEle = Nothing
        End If
    Next rCell
    On Error GoTo 0
    
ExitTheSub:
    Set IE = Nothing
    Set HTMLDoc = Nothing
    Set HTMLEle = Nothing
    
End Sub