Fix Hyperlinks | Replace This with That

[adavid]

I need to fix some hyperlinks. The file names are the same; it's just the address in front of the last "\" that needs to change. The code I have is below, but I cannot get it to work. Any suggestions are greatly appreciated.

Sub FixHyperlinks()

Dim NewPath As String
Dim NewfName As String
Dim GetFilenameFromPath As String
Dim oColumn As Range
    Set oColumn = GetColumn(1)

    Dim oCell As Range
    For Each oCell In oColumn.Cells

        If oCell.Hyperlinks.Count > 0 Then
    
        Call GetAddress
        
            Dim oHyperlink As Hyperlink
            Set oHyperlink = oCell.Hyperlinks(1) ' I assume only 1 hyperlink per cell

            Dim strResult As String
            strResult = oCell.Hyperlinks.Address
            
            strPath = strResult
            
            NewPath = "\\marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\WAMS added to WAM Track\"
            NewfName = NewPath & GetFilenameFromPath
        End If

    Next oCell

End Sub

Function GetAddress(HyperlinkCell As Range)

    GetAddress = Replace(HyperlinkCell.Hyperlinks(1).Address, "mailto:", "")

End Function


Function FunctionGetFileName(FullPath As String) As String
'Update 20140210
Dim splitList As Variant
splitList = VBA.Split(FullPath, "\")
FunctionGetFileName = splitList(UBound(splitList, 1))
End Function

Private Function GetColumn() As Range
    Set GetColumn = ActiveWorkbook.Worksheets(1).Range("A:A")
End Function

 

[Jerry Sullivan]

Hi adavid,

A few comments on your posted code....
1. The code has several errors that could be detected prior to running by placing Option Explicit at the top of your code module.

2. From your use of the statement "Call GetAddress" you might be having difficulty understanding how functions like that work.
The function call requires an Argument HyperlinkCell of Type Range, and it returns a String which needs to be stored or directly used by your calling procedure to have any benefit.
This is an example of how that could be used....

sOldPath=GetAddress(HyperlinkCell:=oCell)

There's some other errors but I'll limit my feedback to those.

Here's a modified version you could try...

Option Explicit

Sub FixHyperlinks()

 Dim sOldPath As String, sFileName As String
 Dim oHyperlink As Hyperlink
 Dim rCell As Range
        
 Const sNEWPATH As String = _
   "\\marnv006\Bm\Master Scheduling\PC 2.2.11 Work Authorizing Memorandum (WAMs)\WAMS added to WAM Track\"
     
 For Each rCell In Worksheets(1).Range("A:A")
   If rCell.Hyperlinks.Count > 0 Then
      Set oHyperlink = rCell.Hyperlinks(1)
      sOldPath = oHyperlink.Address
      sFileName = GetFilenameFromPath(sFullPath:=sOldPath)
      oHyperlink.Address = sNEWPATH & sFileName
   End If
 Next rCell

End Sub

Function GetFilenameFromPath(sFullPath As String) As String
 Dim vSplitList As Variant

 vSplitList = VBA.Split(sFullPath, "\")
 GetFilenameFromPath = vSplitList(UBound(vSplitList, 1))
End Function