Search Webpage for word

[mrpetreli]

I have a list of websites in a column B. How do I search each webpage for a specific word.

I read the help topic t-36107 here but more help would be appreciated.

[mdmackillop]

One way here. What is the desired result?

[mrpetreli]

Desired result ... if the website url is in column B return True or False in the adjacent cell Column C

[mdmackillop]

Based upon this

Option Explicit
Option Compare Text


Sub WebSearch()
        Dim site As String, msg As String
        Dim lastRow As Long
        Dim ie
        Dim TextToFind As String
        Dim i As Long
        
        TextToFind = "website"


        With ActiveSheet
            lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        End With
            Set ie = CreateObject("internetexplorer.application")
            ie.Visible = True
            'idle while ie is busy
            For i = 1 To lastRow
                site = Range("C" & i).Value
                ie.Navigate site
            Do
            Loop Until ie.ReadyState = 3
            Do
            Loop Until ie.ReadyState = 4
        msg = ie.Document.Body.innerhtml
        Range("B" & i).Value = InStr(msg, TextToFind) > 0
      Next i
error:
   ie.Quit
End Sub

[Leith Ross]

Hello mrpetreli,

Here is another method you can use. This method is faster and far less error prone than using the IE Browser object for this job.

You actually can have 3 outcomes for a URL: True if the word is found, False if the word is not found, and error if there is a problem reaching or accessing the site. This code provides you will all three.

Initially all the cells in column "C" are set to False. As each URL is opened it is checked for a possible error. If there is an error then the error and it's message are displayed in red font.

If there is no error then the word is searched for in the page source text. If it is found then the cell in column "C" will be changed to True.

Macro Code

Sub FindWordInPage()


    Dim Keyword As String
    Dim Rng     As Range
    Dim RngBeg  As Range
    Dim Text    As String
    Dim URL     As Variant
    Dim Wks     As Worksheet
    
        Set Wks = Worksheets("Sheet1")
        
        Set RngBeg = Wks.Range("B2")
        
        Keyword = Range("A2")
        
            Set Rng = Wks.Range(RngBeg, Wks.Cells(Rows.Count, RngBeg.Column).End(xlUp))
            If Rng.Row < RngBeg.Row Then Exit Sub
            
            Rng.Offset(0, 1).Value = False
            Rng.Offset(0, 1).Font.ColorIndex = xlColorIndexAutomatic
             
            With CreateObject("MSXML2.XMLHTTP")
                For Each URL In Rng.Cells
                    .Open "GET", URL, False
                    .Send
                    If .Status = 200 Then
                        Text = .responseText
                        If InStr(1, Text, Keyword) > 0 Then URL.Offset(0, 1) = True
                    Else
                        URL.Offset(0, 1).Font.Color = vbRed
                        URL.Offset(0, 1).Value = "ERROR: - " & .Status & " " & .statusText
                    End If
                Next URL
            End With
    
End Sub

[mdmackillop]

Thanks Leith,
A much better solution

[Leith Ross]

Hello mdmackillop,

'S e do bheatha!

Glad you like it. This can not be used to replace all of IE functionality but it handy for a lot processing needs.

[mrpetreli]

Thanks guys, I will test this out soon

[snb]

Use arrays if possible.

Sub M_snb() 
    sn = sheets("Sheet1").cells(1).currentregion.resize(,3) 

    With CreateObject("MSXML2.XMLHTTP") 
       For j=2 to ubound(sn) 
          .Open "GET", sn(j,2), False 
          .Send 
          sn(j,3)= instr(.responsetext,sn(1,1))>0 
       Next 
    End With 

  sheets("Sheet1").cells(1).currentregion.resize(,3)=sn
End Sub

[mrpetreli]

Hi Guys

I am getting Error (Access Denied) on .send ..could it be to do with MSXML2.XMLHTTP ? How do enable that in references library as I don't see it there

    With CreateObject("MSXML2.XMLHTTP") 
        For Each URL In Rng.Cells 
            .Open "GET", URL, False 
            .Send

[mdmackillop]

I can run that code with these references

[mrpetreli]

I can run that code with these references

I changed the internet options > security tab > custom security level > Miscellaneous >Access data sources across domains > enable

This is the error I am getting now
Run-time error '-2147467259(80004005)'