Get current URL FROM IE

[Sharid]

I need to get the current url from IE. I have a list of url on Sheet2 (URL LIST), the url are as

https://www.bbc.co.uk/1234

However when you click on the URL and it opens in IE it actually reads

https://www.bbc.co.uk/1234/john

This above URL is the one that I need, my code works fine for fetching web data, I now have a second command button that need to ONLY get the current url showing in IE. The only bit of code that may need changing is the part in red, I thought this was the answer currenturl = ie.LocationURL but it did not work.

There are over 6000 URL

Private Sub CommandButton2_Click()
Dim i, j, k, l As Integer
    i = 2[COLOR=#000000][/COLOR]
    k = 2
    l = 2
'SHEET2 as sheet with URL
    Dim wsSheet As Worksheet, Rows As Long, links As Variant, ie As Object, link As Variant
    Set wb = ThisWorkbook
    Set wsSheet = wb.Sheets("URL LIST")

'Set IE = InternetExplorer
    Set ie = CreateObject("InternetExplorer.Application")
    Rows = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
    links = wsSheet.Range("A1:A" & Rows)

'IE Open Time per page 5sec and check links on Sheet2 Column A
    With ie
        .Visible = True
        Application.Wait (Now + TimeValue("00:00:5"))
[COLOR=#0000cd]
      [/COLOR][COLOR=#000000]  For Each link In links
            .navigate (link)
            While .Busy Or .READYSTATE <> 4: DoEvents: Wend

            For i = 1 To 500
                On Error Resume Next

'Paste in sheet and column
                Dim rw As Long
                
                rw = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row + 1[/COLOR][COLOR=#0000cd]
               [/COLOR][COLOR=#ff0000] Sheets("Sheet1").Range("A" & rw).Value = ie.document.getelementsbytagname("a").Item(i).innerText[/COLOR][COLOR=#0000cd]

           [/COLOR][COLOR=#000000] Next i

'Deletes duplicates in column A Sheet1
            Columns(1).RemoveDuplicates Columns:=Array(1)

'navigate links
        Next link


Set sendAnEmail = ie.document.getElementsByClassName("a-link-normal pr-email").Item(0)

sendAnEmail.Click

Application.Wait Now + TimeSerial(0, 0, 2)

retrievedEmail = sendAnEmail.innerText
    End With

'Close IE Browser
    ie.Quit
    Set ie = Nothing
End Sub

[/COLOR]

Thanks

 

[Sharid]

I've taken this code out

[COLOR=#000000] rw = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row + 1[/COLOR][COLOR=#0000cd]
[/COLOR][COLOR=#000000] Sheets("Sheet1").Range("A" & rw).Value = ie.document.getelementsbytagname("a").Item(i).innerText[/COLOR]

And replaced it with this and it seems to work

rw = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row + 1
      Sheets("Sheet1").Range("A" & rw).Cells(1, 1).Value = ie.LocationURL

Unless someone knows how to do it better, this thread is closed