VBA - Tweak code to 'unwrap' shortened URLs for specified range on click

You could use the same function in a range loop, something like the below, sub 'test' will run unwrap over and over until the end of the range:

Sub test()
    Dim rng As Range, rCell As Range
    
    rng = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    
    For Each rCell In rng.Cells
        rCell.Offset(, 1) = unwrap(rCell.Value)
    Next rCell
End Sub

Public Function unwrap(url As String) As String
    Static oRequest As Object
    Set oRequest = CreateObject("WinHTTP.WinHTTPRequest.5.1")
    With oRequest
        .Option(6) = True
        .Option(12) = True
        .Open "HEAD", url, False
        .send
        unwrap = .Option(1)
    End With
End Function

Sorry my mistake - I missed the word Set:

Set rng = Worksheets("Content_Audit").Range("H9:H" & Range("H" & Rows.Count).End(xlUp).Row)

Are you able to paste a sample of your data with a couple of working formulae? (sensitive data removed, maybe you could just leave a couple of fake URL's created by the same formula)

Would be a lot easier to work with.

Do the links created by formulae work when you put them into a web browser URL?

The below will fix the error with the blank (-) cells:

Sub Unwrapper()
    Dim rng As Range, rCell As Range
    
    Set rng = Worksheets("Content_Audit").Range("H9:H" & Range("H" & Rows.Count).End(xlUp).Row)
    
    For Each rCell In rng.Cells
        If rCell.Value <> "-" Then
            rCell.Offset(, 1) = unwrap(rCell.Value)
        End If
    Next rCell
End Sub

To test the ones that are not working: try pasting the formula result into your browser - if you get an error then there could be something wrong with the shortened URL.

Try the below:

Sub Unwrapper()
    Dim rng As Range, rCell As Range
    
    Set rng = Worksheets("Content_Audit").Range("H9:H13")
    
    For Each rCell In rng.Cells
        If rCell.Value <> "" Then
            rCell.Offset(, 1) = Unwrap(rCell.Value)
        End If
    Next rCell
End Sub

Public Function Unwrap(url As String) As String
    Dim h As Object
    Set h = CreateObject("MSXML2.ServerXMLHTTP")
        h.Open "HEAD", url, False
        h.send
    Unwrap = h.getOption(-1) 'final URL even if redirected
End Function

Hey CheeseSandwich,

Thanks so much for this! Tried, but sadly not giving me the final URL (it does for some, but not for all) :-(

But - good news is - I found this awesome redirect checker script here that seems to do the job:

Private Changing As Boolean

Private Sub RedirectChecker(ByVal url As String)
    Dim sh As Worksheet
    Set sh = ActiveSheet
    
    Dim http As New WinHttp.WinHttpRequest
    http.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
    http.Option(WinHttpRequestOption_EnableRedirects) = False
    
    '' Clear existing info
    sh.Cells(3, 3).Formula = ""
    sh.Cells(4, 3).Formula = ""
    DoEvents
    
    '' Add protocol if missing
    If (InStr(url, "://") = 0) Then
        url = "http://" & url
    End If
    
    '' Launch the HTTP request
    http.Open "GET", url
    If Err.Number <> 0 Then
        '' Handle URL formatting errors
        sh.Cells(3, 3).Formula = Trim(Err.Description)
        Exit Sub
    End If
    http.Send
    If Err.Number <> 0 Then
        '' Handle HTTP errors
        sh.Cells(3, 3).Formula = Trim(Err.Description)
        Exit Sub
    End If
    '' Show HTTP response info
    sh.Cells(3, 3).Formula = http.Status & " " & http.StatusText
    sh.Cells(4, 3).Formula = http.GetResponseHeader("Location")
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Changing Then Exit Sub
    Changing = True
    Dim Name As String
    On Error Resume Next
    Name = Target.Name.Name
    If Name = "URL" Then
        RedirectChecker Target.Value
    End If
    On Error GoTo 0
    Changing = False
End Sub

This works perfectly, however, sadly it only looks at 1 input URL, not a range. Not quite sure how I could tweak it to:

a) look at range Worksheets("Content_Audit").Range("H9:H1008") and check status and final URL for each cell in that range
b) write the Redirect Value into the cell to the right of the input URL (column I)
c) write the final URL into the cell two cells to the right of the input URL (column J)
d) Execute this on click, rather than automatically

Do you have any idea? Think that would really be it (appreciate the support!).

Maybe something like:

Sub Unwrapper()
    Dim rng As Range, rCell As Range, wsCA As Worksheet
    
    Set wsCA = Sheets("Content_Audit")
    With wsCA
        Set rng = .Range("H9:H" & .Range("H" & Rows.Count).End(xlUp).Row)
    End With
    
    For Each rCell In rng.Cells
        If rCell.Value <> "" Then
            rCell.Offset(, 1) = rCell.Value
            rCell.Offset(, 2) = unwrap(rCell.Value)
        End If
    Next rCell
End Sub

Function unwrap(url As String)
    Dim http As New WinHttp.WinHttpRequest
    
    http.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
    http.Option(WinHttpRequestOption_EnableRedirects) = False
    http.Open "GET", url
    http.Send
    unwrap = http.GetResponseHeader("Location")
End Function

For the error i think you need to add a reference in the VBE: Microsoft WinHTTP Services

For the second part, try the below:

Sub Unwrapper()
    Dim rng As Range, rCell As Range, wsCA As Worksheet, str As String
    
    Set wsCA = Sheets("Content_Audit")
    With wsCA
        Set rng = .Range("H9:H" & .Range("H" & Rows.Count).End(xlUp).Row)
    End With
    
    For Each rCell In rng.Cells
        If rCell.Value <> "" Then
            str = unwrap(rCell.Value)
            rCell.Offset(, 1) = Split(str, "|")(0)
            rCell.Offset(, 2) = Split(str, "|")(1)
        End If
    Next rCell
End Sub

Function unwrap(url As String)
    Dim http As New WinHttp.WinHttpRequest
    
    http.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
    http.Option(WinHttpRequestOption_EnableRedirects) = False
    http.Open "GET", url
    http.Send
    unwrap = http.Status & " " & http.StatusText & "|" & http.GetResponseHeader("Location")
End Function