Work object not defined

[eshu153]

I am trying to search a string from a website using VBA. I 4 websites in one column and 4 search strings in another column. I need to assign the column range to variables which was giving error object not defined. Any suggestions please
Here is the code am using.

Option Explicit
[COLOR=#ff0000]
Sub LookForText()[/COLOR]
    Dim rngURL As Range
    Dim cll As Range
    Dim stCheck As Range
    Dim xmlHttp As Object
    Dim currentWorksheet As Worksheet
    On Error Resume Next
    Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
    If xmlHttp Is Nothing Then
        MsgBox "Unable to create XMLHTTP object, it's probably not installed on this machine", vbCritical
        Exit Sub
    End If

    Set rngURL = Application.InputBox("Select the range of URLs to check", "Select Range", Selection, Type:=8)
    On Error GoTo 0

    If rngURL Is Nothing Then Exit Sub

    Set stCheck = currentWorksheet.Range("H2", "H5")

    If Len(stCheck) = 0 Then Exit Sub

    For Each cll In rngURL.Cells
        If CheckURL(xmlHttp, cll.Value, stCheck) Then
            cll.Offset(, 1).Value = 1
        End If
    Next cll

End Sub

Private Function CheckURL(ByRef xmlHttp As Object, ByVal URL As String, ByVal stCheck As String) As Boolean
    Dim stResult As String

    If Not LCase$(URL) Like "http://*" Then
        URL = "http://" & URL
    End If

    xmlHttp.Open "GET", URL, False
    xmlHttp.Send ""

    If xmlHttp.readyState = 4 Then
        If xmlHttp.Status = 200 Then
            stResult = xmlHttp.responseText

            If InStr(1, stResult, stCheck, vbBinaryCompare) > 0 Then
                CheckURL = True
            End If
        End If
    End If
End Function

't


[COLOR=#ff0000]Sub LookForText()[/COLOR]
    Dim rngURL As Range
    Dim cll As Range
    Dim stCheck As Range
    Dim xmlHttp As Object
    Dim currentWorksheet As Worksheet
    On Error Resume Next
    Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
    If xmlHttp Is Nothing Then
        MsgBox "Unable to create XMLHTTP object, it's probably not installed on this machine", vbCritical
        Exit Sub
    End If

    Set rngURL = Application.InputBox("Select the range of URLs to check", "Select Range", Selection, Type:=8)
    On Error GoTo 0

    If rngURL Is Nothing Then Exit Sub

    Set stCheck = currentWorksheet.Range("H2", "H5")

    If Len(stCheck) = 0 Then Exit Sub

    For Each cll In rngURL.Cells
        If CheckURL(xmlHttp, cll.Value, stCheck) Then
            cll.Offset(, 1).Value = 1
        End If
    Next cll

End Sub

Private Function CheckURL(ByRef xmlHttp As Object, ByVal URL As String, ByVal stCheck As String) As Boolean
    Dim stResult As String

    If Not LCase$(URL) Like "http://*" Then
        URL = "http://" & URL
    End If

    xmlHttp.Open "GET", URL, False
    xmlHttp.Send ""

    If xmlHttp.readyState = 4 Then
        If xmlHttp.Status = 200 Then
            stResult = xmlHttp.responseText

            If InStr(1, stResult, stCheck, vbBinaryCompare) > 0 Then
                CheckURL = True
            End If
        End If
    End If
End Function

 

[mole999]

when you compile it, excel warns that the two I have highlighted in RED are duplicates

I think your intention was to post once which would provide

Option Explicit
[COLOR=#ff0000]
Sub LookForText()[/COLOR]
    Dim rngURL As Range
    Dim cll As Range
    Dim stCheck As Range
    Dim xmlHttp As Object
    Dim currentWorksheet As Worksheet
    On Error Resume Next
    Set xmlHttp = CreateObject("Microsoft.XMLHTTP")
    If xmlHttp Is Nothing Then
        MsgBox "Unable to create XMLHTTP object, it's probably not installed on this machine", vbCritical
        Exit Sub
    End If

    Set rngURL = Application.InputBox("Select the range of URLs to check", "Select Range", Selection, Type:=8)
    On Error GoTo 0

    If rngURL Is Nothing Then Exit Sub

    Set stCheck = currentWorksheet.Range("H2", "H5")

    If Len(stCheck) = 0 Then Exit Sub

    For Each cll In rngURL.Cells
        If CheckURL(xmlHttp, cll.Value, stCheck) Then
            cll.Offset(, 1).Value = 1
        End If
    Next cll

End Sub

Private Function CheckURL(ByRef xmlHttp As Object, ByVal URL As String, ByVal stCheck As String) As Boolean
    Dim stResult As String

    If Not LCase$(URL) Like "http://*" Then
        URL = "http://" & URL
    End If

    xmlHttp.Open "GET", URL, False
    xmlHttp.Send ""

    If xmlHttp.readyState = 4 Then
        If xmlHttp.Status = 200 Then
            stResult = xmlHttp.responseText

            If InStr(1, stResult, stCheck, vbBinaryCompare) > 0 Then
                CheckURL = True
            End If
        End If
    End If
End Function

 

[eshu153]

You have highlighted sub name. I don't get it.

 

[eshu153]

By mistake i have copied it twice. But in real VBA editor it's not duplicated. Now I guess you can suggest me.

 

[Norie]

I'll suggest something, you never set currentWorksheet to refer to anything.

 

[eshu153]

So, how will I achieve my target of using current sheet?

Is there any other way.

 

[mole999]

activesheet.

 

[eshu153]

Oh thanks. I got it.