Excel VBA to Check website for values and update Cells in workbook

[torz]

2Hi All,

Hoping that someone can point out where I am going wrong.
I'm trying to adapt some code I that I had come across quite some time ago - I can get it working to an extent but not 100%.
I do have a sample sheet but can't for the life of me find where to upload it... So I'll post both code blocks and explain the issue as best as I can...

Public Sub CheckDockets()

'http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_26686033.html (I believe this is where the code came from originally, so props!)

    Dim objIE As Object
    Dim objxmlhttp As Object
    Dim strURL

    On Error GoTo errhandler
    strURL = "http://www.website.com.au/blah.asp?=INC123123123"
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.navigate "about:blank"

    Set objxmlhttp = CreateObject("Microsoft.xmlhttp")
    With objxmlhttp
        .Open "GET", strURL, False
        objxmlhttp.setRequestHeader "Content-Type", "text/xml"
        objxmlhttp.send
        If .Status = 200 Then
        Debug.Print objxmlhttp.responseText
            objIE.document.write objxmlhttp.responseText
            [B]'ActiveSheet.Range("H2").value = objIE.document.getElementById("lblLastResolvedDate").value[/B]
            ActiveSheet.Range("I2").value = objIE.document.getElementById("txtResolution").value
        Else
            MsgBox "no reponse from site"
        End If
    End With
    objIE.Quit
    Set objIE = Nothing
    Exit Sub

errhandler:
    MsgBox "Code failed on" & vbNewLine & Err.Description
    objIE.Quit
    Set objIE = Nothing
    
End Sub

So this code does work as expected except for the bold line, if the comment is removed it will break on that line.
The next code block is what I would ideally like to work properly the idea:
It loops through column G if the value is null/blank it will just count it.
If there is a value in the cell it will navigate to the website+cell.value and hopefully get 2 values off the page when loaded (resolution date and reason). If I can only get one - I'll live with that.
These 2 values should then be updated in the workbook in the adjacent columns H & I.

Public Sub CheckDockets()

    Dim objIE As Object
    Dim objxmlhttp As Object
    Dim strURL
    Dim r As Range, cell As Range
    Dim NoDocketRaised As Integer
    Dim totaldockets As Integer
    Dim ResolveDate As String
    Dim Resolution As String

 '   On Error GoTo errhandler
    totaldockets = WorksheetFunction.CountA(Range("G2", "G" & Range("G2").CurrentRegion.Rows.Count))
    NoDocketRaised = 0
    Set r = Range("G2", "G" & Range("G2").CurrentRegion.Rows.Count)
    
    For Each cell In r
        If IsNull(cell.value) Or cell.value = "" Then
            NoDocketRaised = NoDocketRaised + 1
        Else
        strURL = "http://www.website.com.au/blah.asp?=" & cell.value
            Debug.Print strURL
            
            Set objIE = CreateObject("InternetExplorer.Application")
            objIE.navigate "about:blank"

            Set objxmlhttp = CreateObject("Microsoft.xmlhttp")
            With objxmlhttp
                .Open "GET", strURL, False
                objxmlhttp.setRequestHeader "Content-Type", "text/xml"
                objxmlhttp.send
                If .Status = 200 Then
                    Debug.Print objxmlhttp.responseText
                    objIE.document.write objxmlhttp.responseText
[B]                    'ActiveSheet.Range(cell.Offset(0, 1)).Value = objIE.document.getElementById("lblLastResolvedDate").Value
                    ActiveSheet.Range(cell.Offset(0, 2)).value = objIE.document.getElementById("txtResolution").value[/B]
                 Else
                    MsgBox "no reponse from site"
                 End If
            End With
        End If
    Next
        Set objIE = Nothing
    Exit Sub
    
'errhandler:
'    MsgBox "Code failed on" & vbNewLine & Err.Description
'    objIE.Quit
'    Set objIE = Nothing
    
End Sub

as far as I can tell it all works fine until it goes to update the cell value (bold lines) & it throws the error "object variable or with block variable not set" & I'm assuming its going to have the same issue with the lbl id on the commented line as well.

I hope its something small that I've overlooked - been driving me crazy for awhile now

Thanking you all in advance!

 

[Rijnsent]

Hi torz,

I have some pointers only, as the page you refer to doesn't exist I can't check the code. Things that you could try:
-replace the variable you've called "cell" (For Each cell In r) -> cell is a name/object/property that excel itself uses, so it's bad practice to use it as a variable name. That might cause problems with VBAs own logic, "myCell" or so would be better
-probably Excel has a problem with " ActiveSheet.Range(cell.Offset(0, 2)).value" too, what I would do to check this: split that line into 2 lines: ActiveSheet.Range(cell.Offset(0, 2)).value = 1 and the next line debug.print objIE.document.getElementById("txtResolution").value , that way you can debug to find out which part of the line causes the problem. My guess is the first bit, you could replace that with MyCell(1,1).offset(0,2).value = 1, that probably works.
-Why objIE.document.getElementById("lblLastResolvedDate").Value would give nothing/an error is a mystery to me as I don't have the source of the website, it looks like something that should work. Maybe this post is of any assistance? http://www.mrexcel.com/forum/excel-...-91-excel-2003-macro-windows-xp-ie-8-0-a.html

Cheers,
Koen

 

[torz]

4Thanks for the ideas Koen!

I change to MyCell as suggested - no effect at all so I split the line like mentioned and it is the first 1/2 of the line causing the issues...
ActiveSheet.Range(cell.Offset(0, 2)).value =

any ideas??

 

[torz]

In case anyone else is having issues trying to do this kind of stuff... finally got it working - slightly differnet code (seems to work faster for me as well)

Dim oHttp As MSXML2.XMLHTTP
Dim sURL As String
Dim HTMLDoc As HTMLDocument
Dim c As Range

' Create an XMLHTTP object
Set oHttp = New MSXML2.XMLHTTP

For Each c In Range("G2", "G" & Range("G2").CurrentRegion.Rows.Count) 'change to however you want to loop through the items

' get the URL to open
sURL = "website to look up" & c.value
MsgBox sURL
' Open socket and get website html
oHttp.Open "GET", sURL, False
oHttp.Send
Set HTMLDoc = New HTMLDocument
With HTMLDoc
'Assign the returned text to a HTML document


.body.innerHTML = oHttp.responseText
Cells(30, 1) = .body.innerHTML


' find and place the returned text in the sheet (skip errors)
On Error Resume Next
c.Offset(0, 1) = .getElementById("txtResolution").innerHTML
c.Offset(0, 2) = .getElementById("lblLastResolvedDate").innerHTML
On Error GoTo 0
End With

Next c

'Clean up
Set oHttp = Nothing

End Sub2

 

[Rijnsent]

Hi torz,

that was at the end of my point 2 .
ActiveSheet.Range(cell.Offset(0, 2)).value = 1
->
MyCell(1,1).offset(0,2).value = 1
The cause of the error is that VBA can't "translate" your statement into a valid range where to put the one. I'm not 100% sure how to explain it better, but am pretty sure the bit I wrote should do the job.

On a sidenote: if you record a macro, the code will contain lots of .activate, .select, activesheet and activeworkbook. In coding, I hardly ever use those in my macros, maximum one time to refer to it like so:
Set Sht = Activesheet
Set that in the beginning of your code and use Sht afterwards, so you always know what you're referring to. If a user accidentally selects another sheet during the macro or somehow the focus shifts, the macro will crash with lots of Activesheet/select/activate statements.

Hope that helps,

Koen