[Solved] Word macro to replace hyperlinks

[yanlok1345]

Hi everyone,

Thanks for the help of administrator. I can use the following word macro to replace specific hyperlinks.
(Here's my previous post: https://eileenslounge.com/viewtopic.php ... 26&t=40237)

I would like to inquire whether the following macro is capable of identifying hyperlinked text in the color wdRed and replacing only those specific hyperlinked text. Since my document already contains some hyperlinked text that is different from the ones I want to replace, the macro provided is unable to skip them as effectively as a human would. As a result, an error occurred.

Code: Select all

Sub Test()
    Dim EXL As Object
    Dim Wbk As Object
    Dim Wsh As Object
    Dim f As Boolean
    Dim r As Long
    Dim m As Long
    Dim v As String
    Dim t As Long
    Dim a As String
    Dim p As Long
    Dim xlsPath As String

    ' Prompt for Excel file
    xlsPath = BrowseForFile("Please choose an Excel file", True)
    If xlsPath = vbNullString Then
        Beep
        Exit Sub
    End If

    On Error Resume Next
    ' Get Excel if it is already running
    Set EXL = GetObject(Class:="Excel.Application")
    If EXL Is Nothing Then
        ' Otherwise start it
        Set EXL = CreateObject(Class:="Excel.Application")
        f = True
    End If
    On Error GoTo ErrHandler

    ' Open the workbook
    Set Wbk = EXL.Workbooks.Open(xlsPath)
    Set Wsh = EXL.Worksheets(1)
    ' Last used row
    m = Wsh.Range("A" & Wsh.Rows.Count).End(-4162).Row
    ' Loop through the rows
    For r = 2 To m
        ' Get the time
        v = Wsh.Range("B" & r).Value
        t = 3600 * Left(v, 2) + 60 * Mid(v, 3, 2) + Right(v, 2)
        a = ActiveDocument.Hyperlinks(r - 1).Address
        ' Find position of =Time
        p = InStrRev(a, "Time")
        ' New URL
        a = Left(a, p - 1) & t
        ' Update hyperlink address
        ActiveDocument.Hyperlinks(r - 1).Address = a
    Next r

ExitHandler:
    On Error Resume Next
    Wbk.Close SaveChanges:=False
    If f Then
        EXL.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

I have tried to add With selection.find, then .font.colorindex = wdred but invain.

Many thanks for your help again.

[HansV]

Try this version:

Code: Select all

Sub Test()
    Dim EXL As Object
    Dim Wbk As Object
    Dim Wsh As Object
    Dim f As Boolean
    Dim r As Long
    Dim m As Long
    Dim v As String
    Dim t As Long
    Dim a As String
    Dim p As Long
    Dim xlsPath As String
    Dim hyp As Hyperlink

    ' Prompt for Excel file
    xlsPath = BrowseForFile("Please choose an Excel file", True)
    If xlsPath = vbNullString Then
        Beep
        Exit Sub
    End If

    On Error Resume Next
    ' Get Excel if it is already running
    Set EXL = GetObject(Class:="Excel.Application")
    If EXL Is Nothing Then
        ' Otherwise start it
        Set EXL = CreateObject(Class:="Excel.Application")
        f = True
    End If
    On Error GoTo ErrHandler

    ' Open the workbook
    Set Wbk = EXL.Workbooks.Open(xlsPath)
    Set Wsh = EXL.Worksheets(1)
    ' Last used row
    m = Wsh.Range("A" & Wsh.Rows.Count).End(-4162).Row
    ' Loop through the rows
    For r = 2 To m
        Set hyp = ActiveDocument.Hyperlinks(r - 1)
        If hyp.Range.Font.ColorIndex = wdRed Then
            ' Get the time
            v = Wsh.Range("B" & r).Value
            t = 3600 * Left(v, 2) + 60 * Mid(v, 3, 2) + Right(v, 2)
            a = hyp.Address
            ' Find position of =Time
            p = InStrRev(a, "Time")
            ' New URL
            a = Left(a, p - 1) & t
            ' Update hyperlink address
            hyp.Address = a
        End If
    Next r

ExitHandler:
    On Error Resume Next
    Wbk.Close SaveChanges:=False
    If f Then
        EXL.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[yanlok1345]

Try this version:

Code: Select all

Sub Test()
    Dim EXL As Object
    Dim Wbk As Object
    Dim Wsh As Object
    Dim f As Boolean
    Dim r As Long
    Dim m As Long
    Dim v As String
    Dim t As Long
    Dim a As String
    Dim p As Long
    Dim xlsPath As String
    Dim hyp As Hyperlink

    ' Prompt for Excel file
    xlsPath = BrowseForFile("Please choose an Excel file", True)
    If xlsPath = vbNullString Then
        Beep
        Exit Sub
    End If

    On Error Resume Next
    ' Get Excel if it is already running
    Set EXL = GetObject(Class:="Excel.Application")
    If EXL Is Nothing Then
        ' Otherwise start it
        Set EXL = CreateObject(Class:="Excel.Application")
        f = True
    End If
    On Error GoTo ErrHandler

    ' Open the workbook
    Set Wbk = EXL.Workbooks.Open(xlsPath)
    Set Wsh = EXL.Worksheets(1)
    ' Last used row
    m = Wsh.Range("A" & Wsh.Rows.Count).End(-4162).Row
    ' Loop through the rows
    For r = 2 To m
        Set hyp = ActiveDocument.Hyperlinks(r - 1)
        If hyp.Range.Font.ColorIndex = wdRed Then
            ' Get the time
            v = Wsh.Range("B" & r).Value
            t = 3600 * Left(v, 2) + 60 * Mid(v, 3, 2) + Right(v, 2)
            a = hyp.Address
            ' Find position of =Time
            p = InStrRev(a, "Time")
            ' New URL
            a = Left(a, p - 1) & t
            ' Update hyperlink address
            hyp.Address = a
        End If
    Next r

ExitHandler:
    On Error Resume Next
    Wbk.Close SaveChanges:=False
    If f Then
        EXL.Quit
    End If
    Exit Sub

ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

Many thanks for your help! It works well!