Get Underlying Hyperlinks Out of Friendly Names

[XL-Dennis]

Hi all :hi

Unlike other boards I like to see that we also include error-handling in the provided solutions, especially when they are supposed to be used by less skilled user.

Therefore I made the following add-ons:

Option Explicit
Sub Do_It()
Dim rnSource As Range, rnStart As Range, rnTarget as Range
If ActiveSheet.ProtectContents = False Then
    If TypeName(Selection) = "Range" Then
        With Selection
            If .Columns.Count <> 1 Then
                MsgBox "Please make sure that the selection only contains one column.", vbInformation
                GoTo ExitHere
            ElseIf .Areas.Count <> 1 Then
                MsgBox "Please make sure that the selection only covers one area.", vbInformation
                GoTo ExitHere
            Else
                Set rnSource = Selection
            End If
        End With
    Else
        MsgBox "You need to select a range before executing this procedure.", vbExclamation
        GoTo ExitHere
    End If
Else
    MsgBox "You need to unprotect the worksheet before executing this procedure.", vbExclamation
    GoTo ExitHere
End If
On Error Resume Next
Set rnStart = Application.InputBox( _
Prompt:="Please select the first cell in the target range:", _
Title:="Select targetrange", _
Type:=8)
On Error GoTo 0
If rnStart Is Nothing Then
    GoTo ExitHere
Else
    Set rnTarget = rnStart.Resize(rnSource.Rows.Count, 1)
    Transfer rnSource, rnTarget
End If
ExitHere:
Exit Sub
End Sub

Private Sub Transfer(ByRef rng As Range, ByRef Target As Range)
Application.ScreenUpdating = False
rng.Copy
Target.PasteSpecial (xlPasteAll)
With rng
    .Hyperlinks.Delete
End With
With Application
    .CutCopyMode = False
    .ScreenUpdating = True
End With
End Sub

Kind regards,
Dennis