Write all URLs to cells instead

[jamescooper]

Hello, the following code successfully pulls all the URL links from a webpage and puts them in a listbox; how do I modify to put in column A for example?

Thanks.

Sub Getalllinks()


Dim IE As Object


Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False


url_name = Sheet1.Range("E4")
If url_name = "" Then Exit Sub


IE.navigate (url_name)


Do
DoEvents
Loop Until IE.ReadyState = 4


Set AllHyperlinks = IE.Document.getElementsByTagName("A")
Sheet1.ListBox1.Clear


For Each hyper_link In AllHyperlinks
Sheet1.ListBox1.AddItem (hyper_link)
Next


IE.Quit


End Sub

 

[lrobbo314]

Right you are.

Sub Getalllinks()
Dim IE As Object: Set IE = CreateObject("InternetExplorer.Application")
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim AR() As Variant: AR = Range("E4:E" & Range("E" & Rows.Count).End(xlUp).Row).Value
IE.Visible = False
Dim url_name As String

For i = LBound(AR) To UBound(AR)
    url_name = AR(i, 1)

    If url_name = "" Then Exit For
    IE.navigate (url_name)

    Do
        DoEvents
    Loop Until IE.ReadyState = 4

    Set AllHyperlinks = IE.Document.getElementsByTagName("A")
    Sheet1.ListBox1.Clear

    For Each hyper_link In AllHyperlinks
        If InStr(hyper_link, "http://www.awebsite.co.uk/123") Then
            If Not AL.contains(hyper_link) Then AL.Add hyper_link
        End If
    Next
Next i

IE.Quit
Range("A1").Resize(AL.Count, 1).Value = Application.Transpose(AL.toarray)
End Sub

 

[jamescooper]

Ah I put the next there, but should have been next i

So that has solved that now I am getting automation error.

I believe this is to do with the shutting and opening of IE?

 

[lrobbo314]

Can you post some sample data so I can test?

 

[jamescooper]

In E4:E

[TABLE="width: 64"]
<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]https://www.tesco.com/groceries/en-GB/shop/fresh-food?include-children=true

[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/bakery?include-children=true

[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/frozen-food?include-children=true

[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/food-cupboard?include-children=true

[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/drinks?include-children=true

[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/baby?include-children=true[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/health-and-beauty?include-children=true

[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/pets?include-children=true

[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/household?include-children=true[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/home-and-ents?include-children=true

[/TD]
[/TR]
[TR]
[TD]https://www.tesco.com/groceries/en-GB/shop/inspiration-and-events?include-children=true[/TD]
[/TR]
</tbody>[/TABLE]

and then the red.

For Each hyper_link In AllHyperlinks
        If InStr(hyper_link, "[COLOR=#ff0000]tesco.com/[/COLOR]") Then
            If Not AL.contains(hyper_link) Then AL.Add hyper_link

 

[lrobbo314]

This code ran successfully on my end.

Sub Getalllinks()
Dim IE As Object: Set IE = CreateObject("InternetExplorer.Application")
Dim AL As Object: Set AL = CreateObject("System.Collections.ArrayList")
Dim AR() As Variant: AR = Range("E4:E" & Range("E" & Rows.Count).End(xlUp).Row).Value
IE.Visible = False
Dim url_name As String

For i = LBound(AR) To UBound(AR)
    url_name = AR(i, 1)

    If url_name = "" Then Exit For
    IE.navigate (url_name)

    Do
        DoEvents
    Loop Until IE.ReadyState = 4

    Set AllHyperlinks = IE.Document.getElementsByTagName("A")
    Sheet1.ListBox1.Clear

    For Each hyper_link In AllHyperlinks
        If InStr([COLOR=#0000ff]hyper_link.href[/COLOR], "tesco.com/") Then
            If Not AL.contains([COLOR=#0000ff]hyper_link.href[/COLOR]) Then AL.Add [COLOR=#0000ff]hyper_link.href[/COLOR]
        End If
    Next
Next i

IE.Quit
Range("A1").Resize(AL.Count, 1).Value = Application.Transpose(AL.toarray)
End Sub

 

[jamescooper]

Hmm still run-time error -2146232576 automation error.

How strange.

 

[jamescooper]

It fails on this

Set AL = CreateObject("System.Collections.ArrayList")

Is it because of references?

 

[lrobbo314]

I'm guessing an old version of Excel or something. Try this one.

Sub Getalllinks()
Dim IE As Object: Set IE = CreateObject("InternetExplorer.Application")
Dim cnt As Long: cnt = 1
Dim AR() As Variant: AR = Range("E4:E" & Range("E" & Rows.Count).End(xlUp).Row).Value
Dim AL() As Variant
Dim url_name As String

IE.Visible = False

For i = LBound(AR) To UBound(AR)
    url_name = AR(i, 1)

    If url_name = "" Then Exit For
    IE.navigate (url_name)

    Do
        DoEvents
    Loop Until IE.ReadyState = 4

    Set AllHyperlinks = IE.Document.getElementsByTagName("A")
    Sheet1.ListBox1.Clear

    For Each hyper_link In AllHyperlinks
        If InStr(hyper_link.href, "tesco.com/") Then
            ReDim Preserve AL(1 To cnt)
            AL(cnt) = hyper_link.href
            cnt = cnt + 1
        End If
    Next
Next i

IE.Quit
Range("A1").Resize(UBound(AL), 1).Value = Application.Transpose(AL)
End Sub

 

[jamescooper]

That's that is great, I am obtaining duplicate links, how would I ensure the code above does not return the same twice?

Thanks.