Get final URL with Excel VBA

Question

I've been strugling with this issue, and trying to find a solution here in StackOverflow, but nothing helped.

I have thousands of links of images (Column A), that will get you to the final JPG url. It's not a redirect link because I've tried with different websites and it doesn't detect it.

Here is an example: https://www.pepperl-fuchs.com/global/en/doci.htm?docilang=ENG&view=showproductpicbypartno&partno=000046

It will get you here: https://files.pepperl-fuchs.com/webcat/navi/productInfo/pd/d428540a.jpg

So I would like to extrapolate all the final links in Column B. I found some code that opens IE for each link, but it probably misses the function to copy the URL and paste it in the cell:

Sub Test()

    Dim IE As Object
    Dim URL As Range
    Dim objDocument As Object
    Dim x As Integer

    Set IE = CreateObject("InternetExplorer.Application")

    With IE
        .Visible = True
        For Each URL In Range("A2:A16")
            .Navigate URL.Value
            While .busy Or .ReadyState <> 4: DoEvents: Wend

            If LCase(TypeName(objDocument)) = "htmldocument" Then
            Cells(A, 1).Value = objDocument.URL
            Cells(A, 2).Value = objDocument.Title
            x = x + 1
            End If

        Next
    End With

End Sub

Can you guys help me figure out what is missing? Unfortunately I'm not really familiar with VBA.

Thank you very much

Answer 1

Try this

Sub Test()

    Dim IE As Object
    Dim URL As Range
    Dim objDocument As Object
    Dim x As Integer

    Set IE = CreateObject("InternetExplorer.Application")

    With IE
        .Visible = True

        For Each URL In Range("A2:A16")
            .Navigate URL.Value
            While .busy Or .ReadyState <> 4: DoEvents: Wend

            URL.Offset(, 1).Value = .LocationURL
        Next
    End With

End Sub

Answer 2

Try this code

Sub Test()
Dim html        As HTMLDocument
Dim ie          As Object
Dim objDocument As Object
Dim url         As Range
Dim x           As Integer

Set ie = CreateObject("InternetExplorer.Application")
x = 1

With ie
    .Visible = True
    For Each url In Range("A2:A3")
        .navigate url.Value
        While .Busy Or .readyState <> 4: DoEvents: Wend
        Set html = .document

        x = x + 1
        Cells(x, 2).Value = html.url
        Cells(x, 3).Value = html.Title
    Next url
End With
End Sub

Answer 3

Need more to test with but this will be a lot faster and if you can easily adapt to using an array to loop faster than looping sheet by using Dim arr(): arr = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value and looping the first dimension.

Option Explicit
Public Sub GetInfo()
    Dim rng As Range
    With Worksheets("Sheet1")
        For Each rng In .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
            If InStr(rng.Value, "http") > 0 Then Debug.Print GetURL(rng.Value)
        Next
    End With
End Sub
Public Function GetURL(ByVal url As String) As String
    Dim sResponse As String, s As Long, e As Long
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", url, False
        .send
        sResponse = StrConv(.responseBody, vbUnicode)
    End With
    s = InStr(1, sResponse, "https")
    e = InStr(1, sResponse, ".jpg") + 4
    GetURL = Mid(sResponse, s, e - s)
End Function

This does assume that all your links follow the same pattern as the first.