Macro to pull just the information of the URL

[Ursula]

Hello, I'm new here, but I promise, I've searched the last 2 days if someone else has the same problem, but I couldn't find anything.

What I want to do:
I have a list of URL's in a spreadsheet (12,000, but I could run 1,000 at a time) I want to verify if the webpages still exist or not. I used this code so far and it works for up to 6 URLs, if I add more, I get a runtime error- access denied. I tried to add a pause for every loop, but this doesn't solve the problem. The code goes through the whole source of the webpage to find a specific string, which of course, takes too much time. It is ok for 6 URLs, but 10 or 20 is already a problem wit this solution. My idea is if I can write a macro which only returns the URL again, after response from the web. If a webpage doesn't exist you get something like http://www.webaddresshelp.bt.com if you are with BT.

This should take less time, than searching the whole page. I hope someone can help me or has a complete other solution. Anything appreciated. Thanks.

Here is the code I have so far, which leads to a runtime error if I use more than 6 URL's.

[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
Else
Application.Wait Now + TimeSerial(0, 0, 10)
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


]

P.S. I'm using Office 365 on Windows 8

 

[circledchicken]

Hi and welcome to the forum,

Perhaps try this method:
Logicwurks, LLC

 

[Ursula]

Hi and welcome to the forum,

Perhaps try this method:
Logicwurks, LLC

Thanks for your welcome. I tried this version, but for some reason nothing happens at all (not even an error message). I changed the settings in Tools - References and I added the code as a "Module". Is this correct? After saving it, it doesn't even appear as a Macro. I'm sure I do something wrong, but I don't know what.

 

[circledchicken]

Perhaps try something like this:

Sub example()
    
    Dim oRng    As Range
    Dim vArr    As Variant
    Dim i       As Long
    Dim xmlhttp As Object
    
    Set oRng = Range("A2:A1000") ' enter range of cells to test
    
    vArr = oRng.Value2
    Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
    
    On Error Resume Next
        For i = 1 To UBound(vArr, 1)
            If Left(vArr(i, 1), 4) <> "http" Then
                vArr(i, 1) = "http://" & vArr(i, 1)
            End If
            xmlhttp.Open "GET", vArr(i, 1), False
            xmlhttp.Send
            If Err.Number = 0 Then
                vArr(i, 1) = (xmlhttp.Status = 200)
            Else
                vArr(i, 1) = False
            End If
        Next i
    On Error GoTo 0
    
    ' print results in adjacent column
    oRng.Offset(0, 1).Value2 = vArr
    
    Set xmlhttp = Nothing
    
End Sub

Although it will be slow. Test it on a smaller segment of your data. Even just 100 URLs might take around 1 minute.

There might be better / faster ways of doing this that someone else might know.

 

[bertie]

Try this using approach.
I copied the data down 1000 rows. The code processed in 1:30 minutes.

Excel 2007
	A	B
1	http://www.google.com	OK
2	http://www.bbc.co.uk	OK
3	http://www.bertie----axyz.com	FALSE
Sheet1

Place the code in a standard module.

Option Explicit


Sub SearchForString()
   Dim rngURL As Range
   Dim cll As Range
   Dim numUrls As Long
   Dim count As Long


   On Error Resume Next
      Set rngURL = Application.InputBox( _
         Prompt:="Select the range of URLs to check", _
         Title:="Select Range", _
         Default:=Selection, _
         Type:=8) 'refers to range
   On Error GoTo 0
   
   'check user selected range
   If rngURL Is Nothing Then
      MsgBox "No Range Selected!"
      Exit Sub
   End If
   
   'status bar updates
   numUrls = rngURL.count
   
   'loop through the cells in the given range
   For Each cll In rngURL
      'update the status bar
      count = count + 1
      Application.StatusBar = count & "/" & numUrls
      
      'SIMPlE test to check if the cell contains a hyperlink
      'assume the cell text only consists of hyperlink text
      If cll.Hyperlinks.count <> 0 Then
         'output
         cll.Offset(, 1).Value = CheckUrl(cll.Value)
      End If
   Next


End Sub


Private Function CheckUrl(ByVal url As String) As String
   Dim httpReq As Object
   
   Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
   
   On Error Resume Next
   
      With httpReq
         .Open "GET", url, False
         .Send
         
         If Err.Number = 0 Then
            CheckUrl = .StatusText
         Else
            CheckUrl = "False"
         End If
      End With
      
   On Error GoTo 0
End Function

 

[bertie]

Please ignore my last post. This is just checking the validity of the url.

 

[Ursula]

Please ignore my last post. This is just checking the validity of the url.

Fantastic! It works! You are a star. Thanks a lot for your help.