Macro to insert batch hyperlinks from external sheet [pics]

[kaichowyang]

Hi Everyone!

I've been a lurker for sometime and I tried my best to look for the solution in the search and archives but I can seem to find anything.
I was wondering if there was a way to create a macro to insert hyperlinks onto cells with truncated url's (Meaning the rootdomains have been removed. For ex. instead of www.happy.co m/elephants/ it's just /elephants/.)

http://i.imgur.com/SdNQgX6.png

I would like to be able to click the contents and have them link me to the website itself (click /elephants/ and it would take me to [url]www.happy.com/elephants/. I would like to source the hyperlinks from a list of url in another sheet.

http://i.imgur.com/NNN5JY4.png


Is there a way to do this or am I insane ?

Thanks Everyone!

[SamT]

Sub test()
Dim LinkSrc As Variant
Dim LinkTxt As String
LinkSrc = Split(SourceCell, "\", -1)
LinkText = LinkSrc(UBound(LinkSrc))

DestinationCell.Hyperlinks.Add = SourceCell.Hyperlinks(1)
'DestinationCell.Hyperlinks.Hyperlinks(1) = SourceCell.Hyperlinks(1)
DestinationCell.Hyperlinks(1).TextToDisplay = LinkText

End Sub

[kaichowyang]

TY !

I actually used this snippet Sub Batch_Hyperlink()
Dim hl As Hyperlink, strTTD As String, v As Variant
Sheets("URL's").Range("A:A").Copy
Sheets("Title").Range("A1").PasteSpecial xlPasteAll
For Each hl In Sheets("Title").Range("A:A").Hyperlinks
v = Split(hl.Address, "/")
If Len(v(UBound(v))) Then strTTD = v(UBound(v)) Else strTTD = v(UBound(v) - 1)
hl.TextToDisplay = "/" & strTTD & "/"
Next hl
End Sub

but now I'm running into other problems. My current URL source has rootdomain.co m/subdomain/sub-subdomain/ . The result is that is just copies the column but doesn't transform it into a hyperlink or truncates the url. Is the URL length the issue ? Or is it because the data is filtered (CTRL +L then it says "your selection overlaps one or more external data ranges. do you want to convert the selection to a table and remove all external connections")

[SamT]

Sub Batch_Hyperlink()
Dim hl As Hyperlink, strTTD As String, v As Variant
Sheets("URL's").Range("A:A").Copy
Sheets("Title").Range("A1").PasteSpecial xlPasteAll
For Each hl In Sheets("Title").Range("A:A").Hyperlinks
v = Split(hl.Address, "/")
h1.Address = v(0)
If Len(v(UBound(v))) Then
x = UBound(v) - 1
Else
x = UBound(v)
FinalSlash = True
End If
'If need preceding slash SubAdd = "/" & v(1)
'For i = 2 to x
'Else
For i = 1 To x
SubAdd = SubAdd & "/" & v(i)
'End If
If FinalSlash = False Then SubAdd = SubAdd & "/"
h1.SubAddress = SubAdd
strTTD = v(x)
hl.TextToDisplay = strTTD
Next hl
End Sub