Unable to get rid of unwanted links - vba

Question

I've written a script in VBA to parse some links (connected to contact keyword) from a few sites. One link from each site. I used xmlhttp requests to accomplish the task. When I execute my script it does parse links from each site. The only problem is that few sites do not have any such links (connected to contact keyword) and as a result the output in my excel sheet becomes messy. To be clearer: if any site does not have such link, my scraper fill that column with the previous value. I'm storing those collected links just in the next columns of each search. I hope the below Image will bring you the clarity of what I meant.
This is my try so far:
Sub GetConditionalLinks()
Dim HTTP As New XMLHTTP60, Html As New HTMLDocument
Dim post As Object, cel As Range, newlink$, R&
For Each cel In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If cel.Value <> "" Then
With HTTP
.Open "GET", cel.Value, False
.send
Html.body.innerHTML = .responseText
End With
For Each post In Html.getElementsByTagName("a")
If InStr(1, post.innerText, "contact", 1) > 0 Then newlink = post.getAttribute("href"): Exit For
Next post
cel(1, 2) = newlink
End If
Next cel
End Sub
Links I've tried with (I intentionally left few rows blank to see how the script behaves):
https://www.yify-torrent.org/search/1080p/
https://www.houzz.com/professionals/
https://chandoo.org/forum/forums/vba-macros/
https://www.amazon.com/dp/B01LTIORC8
https://stackoverflow.com/questions
https://www.amazon.com/dp/B01LTIORC8
https://www.amazon.com/dp/B00GPAFHIO
The output I'm having:
The output I'm expecting to have:
Search links are in column A and the collected links are in column B. You must have noticed already that the collected links mismatched with the source links because of my looping logic.
My Question:
How can I fix my loop to get the expected output?
What would be the fully qualified line of cel(1, 2), I meant If I mimic something like Worksheets("SomeSheet").Range("A1")?

Answer 1

I would expect you to be able to use something like the following:
Option Explicit
Public Sub GetConditionalLinks()
Dim HTTP As New XMLHTTP60, Html As New HTMLDocument, post As Object, i As Long, arr()
With ActiveSheet
arr = .Range("A1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
With HTTP
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 1) <> vbNullString Then
.Open "GET", arr(i, 1), False
.send
Html.body.innerHTML = .responseText
For Each post In Html.getElementsByTagName("a")
If InStr(1, post.innerText, "contact", 1) > 0 Then arr(i, 2) = post.getAttribute("href"): Exit For
Next post
End If
Next i
End With
.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
End Sub
Access Denied Sites:
So I started getting access denied so re-wrote as the following. Open to suggestions on improving error handling. It is pretty rudimentary but I was trying to avoid GoTo statements.
Option Explicit
Public Sub GetConditionalLinks()
Dim HTTP As New MSXML2.ServerXMLHTTP60, Html As New HTMLDocument, post As Object, i As Long, arr(), timeoutError As Boolean
With ActiveSheet
arr = .Range("A1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
With HTTP
For i = LBound(arr, 1) To UBound(arr, 1)
timeoutError = False
If arr(i, 1) <> vbNullString Then
.Open "GET", arr(i, 1), False
On Error GoTo Errhand
.send
If Not timeoutError Then
Html.body.innerHTML = .responseText
For Each post In Html.getElementsByTagName("a")
If InStr(1, post.innerText, "contact", 1) > 0 Then arr(i, 2) = post.getAttribute("href"): Exit For
Next post
End If
End If
Next i
End With
.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End With
Exit Sub
Errhand:
If Err.Number <> 0 Then
Select Case Err.Number
Case -2147012894 '<== Timeout; especially on access denied sites
timeoutError = True
Resume Next
Case Else '<== Don't know what we are gonna do yet so let's exit
Debug.Print Err.Number, Err.Description
End Select
End If
End Sub
Without using an array and looping sheet:
Option Explicit
Public Sub GetConditionalLinks()
Dim HTTP As New MSXML2.ServerXMLHTTP60, Html As New HTMLDocument, cel As Range, post As Object, R As Long, timeoutError As Boolean
Application.ScreenUpdating = False
With ActiveSheet
For Each cel In .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
R = R + 1: timeoutError = False
If Not IsEmpty(cel) Then
HTTP.Open "GET", cel.Value, False
On Error GoTo Errhand
HTTP.send
If Not timeoutError Then
Html.body.innerHTML = HTTP.responseText
For Each post In Html.getElementsByTagName("a")
If InStr(1, post.innerText, "contact", 1) > 0 Then
.Cells(R, 2) = post.getAttribute("href"): Exit For
End If
Next post
End If
End If
Next cel
End With
Application.ScreenUpdating = True
Exit Sub
Errhand:
If Err.Number <> 0 Then
Select Case Err.Number
Case -2147012894 '<== Timeout; especially on access denied sites
timeoutError = True
Resume Next
Case Else
Debug.Print Err.Number, Err.Description
End Select
End If
Application.ScreenUpdating = True
End Sub

Answer 2

How about doing like the following? Only difining newlink = "" just after the for loop within the script should fix the issue:
Sub GetConditionalLinks()
Dim HTTP As New XMLHTTP60, HTML As New HTMLDocument
Dim post As Object, elem As Object, newlink$
Dim cel As Range, R&
For Each cel In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
newlink = "" '''THIS IS THE FIX
If cel.Value <> "" Then
With HTTP
.Open "GET", cel.Value, False
.send
HTML.body.innerHTML = .responseText
End With
For Each post In HTML.getElementsByTagName("a")
If InStr(1, post.innerText, "contact", 1) > 0 Then newlink = post.getAttribute("href"): Exit For
Next post
cel(1, 2) = newlink
End If
Next cel
End Sub