Need query to return value when true

[DeJuan14]

I am currently running this code that's pieced together from 2 previous macros. I am trying to check a string of URLs in column A for a specific set of text. If the text e.g. "@" is found, the macro returns the number "1" in the adjacent cell in column B.

There's a list of around 10,000 URLs, but the problem comes when the text is "not found" on the webpage. The macro is still returning every URL as true. When I check the actual web address there's no "@" to be found. Is there anyway I can fix this from happening? I need "0" to result from the URLs that do not have the "@"


Sub SearchForString()
Dim rngURL As Range
Dim cll As Range
Dim stCheck As String
Dim xmlHttp As Object

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

stCheck = InputBox("ENTER TEXT TO SEARCH HERE", "", "")

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 = "https://" & 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

 

[igold]

Hi DeJuan14,

Have you stepped (F8) through your code. There is a problem with the values that this line of the Private Function CheckURL is returning:

If InStr(1, stResult, stCheck, vbBinaryCompare) > 0 Then

I added a debug line right below, watched the Immediate Window, and the value getting returned are predominantly over zero.

I don't know what your data looks like but I created a sheet and ran some valid URL's down a column, and then ran your code looking for different "stCheck" variables.

This is the code as tested:

Sub SearchForString()


    Dim rngURL As Range
    Dim cll As Range
    Dim stCheck As String
    Dim xmlHttp As Object


    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
    stCheck = InputBox("ENTER TEXT TO SEARCH HERE", "", "")
    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 = "https://" & 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
[COLOR=#ff0000]            Debug.Print InStr(1, stResult, stCheck, vbBinaryCompare)[/COLOR]
                CheckURL = True
            End If
        End If
    End If
    
End Function

I hope this helps.

igold