Write all URLs to cells instead
Page 2 of 2 FirstFirst 12
Results 11 to 19 of 19

Thread: Write all URLs to cells instead
Thanks Thanks: 0 Likes Likes: 0

  1. #11
    Board Regular lrobbo314's Avatar
    Join Date
    Jul 2008
    Location
    California
    Posts
    2,381
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Write all URLs to cells instead

    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
    To add code to a workbook. Hit Alt+F11. Hit Alt+I+M to insert new module. Then paste code.
    Array formulas must be entered by hitting Ctrl+Shift+Enter.

    We can't solve problems by using the same kind of thinking we used when we created them.

    Imagination is more important than knowledge.

  2. #12
    Board Regular
    Join Date
    Sep 2014
    Posts
    611
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Write all URLs to cells instead

    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?

  3. #13
    Board Regular lrobbo314's Avatar
    Join Date
    Jul 2008
    Location
    California
    Posts
    2,381
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Write all URLs to cells instead

    Can you post some sample data so I can test?
    To add code to a workbook. Hit Alt+F11. Hit Alt+I+M to insert new module. Then paste code.
    Array formulas must be entered by hitting Ctrl+Shift+Enter.

    We can't solve problems by using the same kind of thinking we used when we created them.

    Imagination is more important than knowledge.

  4. #14
    Board Regular
    Join Date
    Sep 2014
    Posts
    611
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Write all URLs to cells instead

    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

    and then the red.

    Code:
    For Each hyper_link In AllHyperlinks
            If InStr(hyper_link, "tesco.com/") Then
                If Not AL.contains(hyper_link) Then AL.Add hyper_link

  5. #15
    Board Regular lrobbo314's Avatar
    Join Date
    Jul 2008
    Location
    California
    Posts
    2,381
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Write all URLs to cells instead

    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(hyper_link.href, "tesco.com/") Then
                If Not AL.contains(hyper_link.href) Then AL.Add hyper_link.href
            End If
        Next
    Next i
    
    IE.Quit
    Range("A1").Resize(AL.Count, 1).Value = Application.Transpose(AL.toarray)
    End Sub
    To add code to a workbook. Hit Alt+F11. Hit Alt+I+M to insert new module. Then paste code.
    Array formulas must be entered by hitting Ctrl+Shift+Enter.

    We can't solve problems by using the same kind of thinking we used when we created them.

    Imagination is more important than knowledge.

  6. #16
    Board Regular
    Join Date
    Sep 2014
    Posts
    611
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Write all URLs to cells instead

    Hmm still run-time error -2146232576 automation error.

    How strange.

  7. #17
    Board Regular
    Join Date
    Sep 2014
    Posts
    611
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Write all URLs to cells instead

    It fails on this
    Code:
    Set AL = CreateObject("System.Collections.ArrayList")
    Is it because of references?

  8. #18
    Board Regular lrobbo314's Avatar
    Join Date
    Jul 2008
    Location
    California
    Posts
    2,381
    Post Thanks / Like
    Mentioned
    4 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Write all URLs to cells instead

    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
    To add code to a workbook. Hit Alt+F11. Hit Alt+I+M to insert new module. Then paste code.
    Array formulas must be entered by hitting Ctrl+Shift+Enter.

    We can't solve problems by using the same kind of thinking we used when we created them.

    Imagination is more important than knowledge.

  9. #19
    Board Regular
    Join Date
    Sep 2014
    Posts
    611
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Write all URLs to cells instead

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

    Thanks.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •