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]

This should do it.

Sub Getalllinks()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
url_name = Sheet1.Range("E4")
Dim RowNum As Long: RowNum = 1

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.Range("A" & RowNum).Value = Hyperlink
    RowNum = RowNum + 1
Next

IE.Quit
End Sub

 

[jamescooper]

Thanks, very good, just 1 minor change to make it run highlighted in red below.

Sub Getalllinks()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
url_name = Sheet1.Range("E4")
Dim RowNum As Long: RowNum = 1

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.Range("A" & RowNum).Value = [COLOR=#ff0000]Hyper_link[/COLOR]
    RowNum = RowNum + 1
Next

IE.Quit
End Sub

 

[jamescooper]

Would there be a way to:

1. Only pull URLs which start with http://www.awebsite.co.uk/123

(for example, instead of all)

2. To loop through multiple URLS, e.g. E4, E5, E6 etc..?

Sub Getalllinks()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
url_name = Sheet1.Range("E4")
Dim RowNum As Long: RowNum = 1

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.Range("A" & RowNum).Value = [COLOR=#ff0000]Hyper_link[/COLOR]
    RowNum = RowNum + 1
Next

IE.Quit
End Sub

Thanks.

 

[lrobbo314]

This should do it.

Sub Getalllinks()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
url_name = Sheet1.Range("E4")
Dim RowNum As Long: RowNum = 1

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
    If InStr(hyper_link, "http://www.awebsite.co.uk/123") Then
        Sheet1.Range("A" & RowNum).Value = hyper_link
        RowNum = RowNum + 1
    End If
Next

IE.Quit
End Sub

 

[jamescooper]

Thanks that is fantastic, and to put the loop in I would amend?

 

[lrobbo314]

I'm not sure what you mean.

 

[jamescooper]

Well, so I can use multiple URLs

e.g.

url_name = Sheet1.Range("E4:E10")

 

[lrobbo314]

I see. Made some changes loading all the info into an arrays. Should make it run faster.

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

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

 

[jamescooper]

Thanks, think missing a "Next" as getting error: "For without next"