VB Macro to search webpage for text string

jt42cwr

Board Regular
Joined
Apr 11, 2007
Messages
50
Hello,

I have a spreadsheet which contains a large number of URL's in column A. I need to launch these one by one and search the text from the resulting web page for a specific text string. If the string is present return "1" in column B next to the URL in column A.

Can anyone help with this?

Thanks.
 

Some videos you may like

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

Juan Pablo González

MrExcel MVP
Joined
Feb 8, 2002
Messages
11,959
Try this

Code:
Option Explicit

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 the text to search", "", "")
   
   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
 

james799

New Member
Joined
Nov 6, 2015
Messages
1

ADVERTISEMENT

Hi,

Apologies for opening an old thread but I didn't want to open a new thread when a releavant one already exists.

I'm very new to VBA in Excel and was wondering if someone can tell me what I would need to add to the above code to get it to work? What would i have to add into the part where it says "Select the range of URLs to check" & "Select Range" if I have a list of URLs that I want to check in column A?

Thanks
 

GeoKoro13

New Member
Joined
Nov 24, 2016
Messages
27
Hi guys,

I'm trying to do something similar with the person that initially add the question but I'm stuck. What I would like to do requires a bit different functionality but I was trying to check what the code does and then try to modify (I have zero experience in coding so whatever I do is by searching and asking). However, I get the following error when I run it.
Capture.PNG


What I ultimately want to do is the following:
I have a file with different proteins (huge list) I want to check on a database for some keywords for each one of them.
Um1Ov.png


So, for instance for each URL (which corresponds on the page for that specific protein) I want to check whether any of the words on the heading (ATP binding, ATPase etc) are present on the page.

Thanks in advance.
George.
 

GeoKoro13

New Member
Joined
Nov 24, 2016
Messages
27
Try this

Code:
Option Explicit

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 the text to search", "", "")
  
   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

Hey Juan, could you please check my comment below if could help me out?

Thanks,
George.
 

Watch MrExcel Video

Forum statistics

Threads
1,126,986
Messages
5,621,992
Members
415,873
Latest member
fuulhouse

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top