Write all URLs to cells instead

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,777
Office Version
365, 2019, 2016
Platform
Windows
Right you are.

Code:
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
 

Some videos you may like

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
771
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

Well-known Member
Joined
Jul 14, 2008
Messages
2,777
Office Version
365, 2019, 2016
Platform
Windows
Can you post some sample data so I can test?
 

jamescooper

Well-known Member
Joined
Sep 8, 2014
Messages
771
In E4:E

https://www.tesco.com/groceries/en-GB/shop/fresh-food?include-children=true

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

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

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

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

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

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

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

https://www.tesco.com/groceries/en-GB/shop/inspiration-and-events?include-children=true

<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>
</tbody>

and then the red.

Code:
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

Well-known Member
Joined
Jul 14, 2008
Messages
2,777
Office Version
365, 2019, 2016
Platform
Windows
This code ran successfully on my end.

Code:
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

Well-known Member
Joined
Sep 8, 2014
Messages
771
It fails on this
Code:
Set AL = CreateObject("System.Collections.ArrayList")
Is it because of references?
 

lrobbo314

Well-known Member
Joined
Jul 14, 2008
Messages
2,777
Office Version
365, 2019, 2016
Platform
Windows
I'm guessing an old version of Excel or something. Try this one.

Code:
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

Well-known Member
Joined
Sep 8, 2014
Messages
771
That's that is great, I am obtaining duplicate links, how would I ensure the code above does not return the same twice?

Thanks.
 

Watch MrExcel Video

Forum statistics

Threads
1,102,633
Messages
5,488,017
Members
407,617
Latest member
Samanthad2007

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top