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
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
Last edited: