|
how to copy 2350 hyperlink full paths to any column in a worksheet ?
Hi all,
First of all, thank for the help I received before. I have another question : I have an excel worksheet, with about 2350 entries. All of them have an hyperlink in column A. I need to find a way to copy ONLY THE HYPERLINKS FULL PATHS of all 2350 cells to column D, NOT THE CELLS CONTENT !! The reason is that from this column D, I can generate playlists without problem. In my search for a solution, I came across following UDF which did not work and gave an error. First of all, I'm not sure if this UDF will solve my problem an secondly, if it does, how can I repare it ? Function HyperLinkText(pRange As Range) As String Dim ST1 As String Dim ST2 As String Dim LPath As String Dim ST1Local As String If pRange.Hyperlinks.Count = 0 Then Exit Function End If LPath = ThisWorkbook.FullName ST1 = pRange.Hyperlinks(1).Address ST2 = pRange.Hyperlinks(1).SubAddress If Mid(ST1, 1, 15) = "..\..\..\..\..\" Then ST1Local = ReturnPath(LPath, 5) & Mid(ST1, 15) ElseIf Mid(ST1, 1, 12) = "..\..\..\..\" Then ST1Local = ReturnPath(LPath, 4) & Mid(ST1, 12) ElseIf Mid(ST1, 1, 9) = "..\..\..\" Then ST1Local = ReturnPath(LPath, 3) & Mid(ST1, 9) ElseIf Mid(ST1, 1, 6) = "..\..\" Then ST1Local = ReturnPath(LPath, 2) & Mid(ST1, 6) ElseIf Mid(ST1, 1, 3) = "..\" Then ST1Local = ReturnPath(LPath, 1) & Mid(ST1, 3) Else ST1Local = ST1 End If If ST2 < "" Then ST1Local = "[" & ST1Local & "]" & ST2 End If HyperLinkText = ST1Local End Function Thanks for any reply ! Kontiki |
Try this one
If I remember correct this is from Dick KusleikaDick Kusleika Dick Kusleika Sub ShowLinks() Dim hlnk As Hyperlink For Each hlnk In Columns("A").Hyperlinks hlnk.Parent.Offset(0, 3).Value = HypToPath(hlnk) Next End Sub Function HypToPath(hyp As Hyperlink) As String Dim CurrAdd As String Dim GoBack As Long Dim CurrFldr As String Dim CAddStrip As String Dim i As Long Dim OldDir As String CurrAdd = hyp.Address CAddStrip = Replace(CurrAdd, "..\", "") CurrFldr = hyp.Parent.Parent.Parent.Path OldDir = CurDir GoBack = (Len(CurrAdd) - Len(CAddStrip)) / 3 If GoBack 0 Then ChDir CurrFldr For i = 1 To GoBack ChDir ".." Next i If Not CurDir Like "?:\" Then CAddStrip = "\" & CAddStrip End If HypToPath = CurDir & CAddStrip ChDir OldDir ElseIf Mid(CurrAdd, 1, 2) = "\\" Then HypToPath = CurrAdd Else HypToPath = CurrFldr & "\" & CurrAdd End If End Function -- Regards Ron de Bruin http://www.rondebruin.nl "kontiki" wrote in message om... Hi all, First of all, thank for the help I received before. I have another question : I have an excel worksheet, with about 2350 entries. All of them have an hyperlink in column A. I need to find a way to copy ONLY THE HYPERLINKS FULL PATHS of all 2350 cells to column D, NOT THE CELLS CONTENT !! The reason is that from this column D, I can generate playlists without problem. In my search for a solution, I came across following UDF which did not work and gave an error. First of all, I'm not sure if this UDF will solve my problem an secondly, if it does, how can I repare it ? Function HyperLinkText(pRange As Range) As String Dim ST1 As String Dim ST2 As String Dim LPath As String Dim ST1Local As String If pRange.Hyperlinks.Count = 0 Then Exit Function End If LPath = ThisWorkbook.FullName ST1 = pRange.Hyperlinks(1).Address ST2 = pRange.Hyperlinks(1).SubAddress If Mid(ST1, 1, 15) = "..\..\..\..\..\" Then ST1Local = ReturnPath(LPath, 5) & Mid(ST1, 15) ElseIf Mid(ST1, 1, 12) = "..\..\..\..\" Then ST1Local = ReturnPath(LPath, 4) & Mid(ST1, 12) ElseIf Mid(ST1, 1, 9) = "..\..\..\" Then ST1Local = ReturnPath(LPath, 3) & Mid(ST1, 9) ElseIf Mid(ST1, 1, 6) = "..\..\" Then ST1Local = ReturnPath(LPath, 2) & Mid(ST1, 6) ElseIf Mid(ST1, 1, 3) = "..\" Then ST1Local = ReturnPath(LPath, 1) & Mid(ST1, 3) Else ST1Local = ST1 End If If ST2 < "" Then ST1Local = "[" & ST1Local & "]" & ST2 End If HyperLinkText = ST1Local End Function Thanks for any reply ! Kontiki |
LOL
Dick KusleikaDick Kusleika Dick Kusleika It is a great guy but 3 times is to much <g -- Regards Ron de Bruin http://www.rondebruin.nl "Ron de Bruin" wrote in message ... Try this one If I remember correct this is from Dick KusleikaDick Kusleika Dick Kusleika Sub ShowLinks() Dim hlnk As Hyperlink For Each hlnk In Columns("A").Hyperlinks hlnk.Parent.Offset(0, 3).Value = HypToPath(hlnk) Next End Sub Function HypToPath(hyp As Hyperlink) As String Dim CurrAdd As String Dim GoBack As Long Dim CurrFldr As String Dim CAddStrip As String Dim i As Long Dim OldDir As String CurrAdd = hyp.Address CAddStrip = Replace(CurrAdd, "..\", "") CurrFldr = hyp.Parent.Parent.Parent.Path OldDir = CurDir GoBack = (Len(CurrAdd) - Len(CAddStrip)) / 3 If GoBack 0 Then ChDir CurrFldr For i = 1 To GoBack ChDir ".." Next i If Not CurDir Like "?:\" Then CAddStrip = "\" & CAddStrip End If HypToPath = CurDir & CAddStrip ChDir OldDir ElseIf Mid(CurrAdd, 1, 2) = "\\" Then HypToPath = CurrAdd Else HypToPath = CurrFldr & "\" & CurrAdd End If End Function -- Regards Ron de Bruin http://www.rondebruin.nl "kontiki" wrote in message om... Hi all, First of all, thank for the help I received before. I have another question : I have an excel worksheet, with about 2350 entries. All of them have an hyperlink in column A. I need to find a way to copy ONLY THE HYPERLINKS FULL PATHS of all 2350 cells to column D, NOT THE CELLS CONTENT !! The reason is that from this column D, I can generate playlists without problem. In my search for a solution, I came across following UDF which did not work and gave an error. First of all, I'm not sure if this UDF will solve my problem an secondly, if it does, how can I repare it ? Function HyperLinkText(pRange As Range) As String Dim ST1 As String Dim ST2 As String Dim LPath As String Dim ST1Local As String If pRange.Hyperlinks.Count = 0 Then Exit Function End If LPath = ThisWorkbook.FullName ST1 = pRange.Hyperlinks(1).Address ST2 = pRange.Hyperlinks(1).SubAddress If Mid(ST1, 1, 15) = "..\..\..\..\..\" Then ST1Local = ReturnPath(LPath, 5) & Mid(ST1, 15) ElseIf Mid(ST1, 1, 12) = "..\..\..\..\" Then ST1Local = ReturnPath(LPath, 4) & Mid(ST1, 12) ElseIf Mid(ST1, 1, 9) = "..\..\..\" Then ST1Local = ReturnPath(LPath, 3) & Mid(ST1, 9) ElseIf Mid(ST1, 1, 6) = "..\..\" Then ST1Local = ReturnPath(LPath, 2) & Mid(ST1, 6) ElseIf Mid(ST1, 1, 3) = "..\" Then ST1Local = ReturnPath(LPath, 1) & Mid(ST1, 3) Else ST1Local = ST1 End If If ST2 < "" Then ST1Local = "[" & ST1Local & "]" & ST2 End If HyperLinkText = ST1Local End Function Thanks for any reply ! Kontiki |
At least you spelled it correctly! <g
Ron de Bruin wrote: LOL Dick KusleikaDick Kusleika Dick Kusleika It is a great guy but 3 times is to much <g -- Debra Dalgleish Excel FAQ, Tips & Book List http://www.contextures.com/tiptech.html |
<vbg
-- Regards Ron de Bruin http://www.rondebruin.nl "Debra Dalgleish" wrote in message ... At least you spelled it correctly! <g Ron de Bruin wrote: LOL Dick KusleikaDick Kusleika Dick Kusleika It is a great guy but 3 times is to much <g -- Debra Dalgleish Excel FAQ, Tips & Book List http://www.contextures.com/tiptech.html |
| All times are GMT +1. The time now is 09:06 AM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com