VB Macro to search webpage for text string

[jt42cwr]

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.

 

[Juan Pablo González]

Try this

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

 

[jt42cwr]

Juan,

It works a treat,

Thanks



Now, I have another query.........

How do I copy text from a table on a webpage and paste it in the same format into spreadsheet cells?

An example of the URL is here: -

http://vred.hznet.hr/hzinfo/default.asp?VAG=987820440020&Category=hzinfo&Service=Arlo&SCREEN=2

I wish to copy the text from the bottom two rows of the table into a worksheet, range say A1:B6?

Thanks

 

[Juan Pablo González]

Take a look at the "Import data from the web" command in the Data menu.

 

[james799]

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]

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.

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.

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]

Try this

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.

 

[MohammadKayed]

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

Thanks,
George.

I have the same issue too