[Solved] Need help about word macro

[yanlok1345]

Hi everyone,

I am new to VBA. I wish to create a macro to do the following:

1. browse and choose the Excel file

Code: Select all

Dim EXL As Object
Dim xlsPath As String
Set EXL = CreateObject("Excel.Application")
xlsPath = BrowseForFile("Please choose an Excel file", True)
If Not xlsPath = vbNullString Then

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
Dim fDialog As FileDialog
    On Error GoTo ERR_HANDLER
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo ERR_HANDLER:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
ERR_HANDLER:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

2. Extract 6-digit numbers from the above selected Excel file to the macro

for example:
000345
000458
000756

3. macro calculates start time from the extracted 6-digit numbers

For example, the 6-digit number in Excel are as follows:

000345
000458
000756

then the start Time (seconds as unit) is equal to =

00*3600 +3*60 +45 =225
00*3600 + 4*60+58 =298
00*3600 + 7*60+56 = 476

Code: Select all

Dim Hr As Integer
  Dim Mn As Integer
  Dim Sc As Integer
  Dim startTime As Long

    Do While .Execute
      ' Get hours, minutes, and seconds from time marker
      hrs = CInt(Left(aRng.Text, 2))
      mins = CInt(Mid(aRng.Text, 3, 2))
      secs = CInt(Right(aRng.Text, 2))
      startTime = hrs * 3600 + mins * 60 + secs

4. Replace Hyperlinks
original hyperlinks are like:

https://xxxxxxx.xxxxx.xxx/xxxxxx/?meeti ... t=Time%201
https://xxxxxxx.xxxxx.xxx/xxxxxx/?meeti ... t=Time%202
https://xxxxxxx.xxxxx.xxx/xxxxxx/?meeti ... t=Time%203

Replace as:
https://xxxxxxx.xxxxx.xxx/xxxxxx/?meeti ... &start=225
https://xxxxxxx.xxxxx.xxx/xxxxxx/?meeti ... &start=298
https://xxxxxxx.xxxxx.xxx/xxxxxx/?meeti ... &start=476

I would like to express my gratitude in advance to anyone who can provide assistance in editing the macro. Thank you!

[HansV]

Welcome to Eileen's Lounge!

Your Excel workbook does not contain 6-digit numbers. It appears the values have already been converted to a number of seconds.

S2466.png

[yanlok1345]

Welcome to Eileen's Lounge!

Your Excel workbook does not contain 6-digit numbers. It appears the values have already been converted to a number of seconds.


S2466.png

Thanks for your reminder! I just re-uploaded it and corrected.

[HansV]

Thanks! Try this:

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 n 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
        ' Get the name
        n = Wsh.Range("A" & r).Value
        ' Get the time
        t = 86400 * TimeValue(Format(Wsh.Range("B" & r).Value, "00:00:00"))
        ' Find the hyperlink corresponding to the name
        For Each hyp In ActiveDocument.Hyperlinks
            If hyp.TextToDisplay = n Then
                ' Get hyperlink address (URL)
                a = hyp.Address
                ' Find position of =Time
                p = InStrRev(a, "=Time")
                ' New URL
                a = Left(a, p) & t
                ' Update hyperlink address
                hyp.Address = a
                Exit For
            End If
        Next hyp
    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

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
    Dim fDialog As FileDialog
    On Error GoTo ERR_HANDLER
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo ERR_HANDLER:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
ERR_HANDLER:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

[yanlok1345]

Thanks! Try this:

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 n 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
        ' Get the name
        n = Wsh.Range("A" & r).Value
        ' Get the time
        t = 86400 * TimeValue(Format(Wsh.Range("B" & r).Value, "00:00:00"))
        ' Find the hyperlink corresponding to the name
        For Each hyp In ActiveDocument.Hyperlinks
            If hyp.TextToDisplay = n Then
                ' Get hyperlink address (URL)
                a = hyp.Address
                ' Find position of =Time
                p = InStrRev(a, "=Time")
                ' New URL
                a = Left(a, p) & t
                ' Update hyperlink address
                hyp.Address = a
                Exit For
            End If
        Next hyp
    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

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
    Dim fDialog As FileDialog
    On Error GoTo ERR_HANDLER
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo ERR_HANDLER:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
ERR_HANDLER:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

Thank you so much for your help! I was struggled it by several months.

However, I found this line has a problem and causing the macro cannot work:

t = 86400 * TimeValue(Format(Wsh.Range("B" & r).value, "00:00:00"))

it said that the "format" is an "invalid statement". May you please help to solve that? A million thanks for your help.

[snb]

I'd use:

Code: Select all

Sub M_snb()
   With GetObject("J:\download\excel file .xlsx")
      sn = .sheets(1).Cells(1).currentregion
      .Close 0
    End With
    
    For j = 2 To UBound(sn)
      c00 = c00 & "_" & sn(j, 1) & "|" & (sn(j, 2) \ 10^4) * 3600 +(sn(j, 2) \ 100) * 60 + sn(j, 2) Mod 100
    Next
    st = Split(c00, "_")
    
    For Each it In Hyperlinks
      it.Address = Left(it.Address, Len(it.Address) - 8) & Split(Filter(st, it.TextToDisplay)(0), "|")(1)
    Next
End Sub

[yanlok1345]

I'd use:

Code: Select all

Sub M_snb()
   With GetObject("J:\download\excel file .xlsx")
      sn = .sheets(1).Cells(1).currentregion
      .Close 0
    End With
    
    For j = 2 To UBound(sn)
      c00 = c00 & "_" & sn(j, 1) & "|" & (sn(j, 2) \ 10^4) * 3600 +(sn(j, 2) \ 100) * 60 + sn(j, 2) Mod 100
    Next
    st = Split(c00, "_")
    
    For Each it In Hyperlinks
      it.Address = Left(it.Address, Len(it.Address) - 8) & Split(Filter(st, it.TextToDisplay)(0), "|")(1)
    Next
End Sub

Many thanks for your help! I found Type mismatch (Error 13) in " For Each it In Hyperlinks".May you please help me to solve that? i would greatly appreciate it if you could help me with this. ><

[HansV]

it said that the "format" is an "invalid statement".

In the Visual Basic Editor, select Tools > References...
Do you see a reference whose check box is ticked (those are always listed at the top) and whose name begins with MISSING: ?
If so, clear its check box, click OK, then try running the macro again.

[snb]

You'll have to store the macro in the macromodule of the document. Do not use a separate Macromodule (like e.g. 'Module1').

[yanlok1345]

it said that the "format" is an "invalid statement".

In the Visual Basic Editor, select Tools > References...
Do you see a reference whose check box is ticked (those are always listed at the top) and whose name begins with MISSING: ?
If so, clear its check box, click OK, then try running the macro again.

1.png

I just have ticked these. I can't find an item called "format" in the References of the Visual Basic Editor's Tools.

[yanlok1345]

You'll have to store the macro in the macromodule of the document. Do not use a separate Macromodule (like e.g. 'Module1').

it works! But my company doesn't allow all of us to use this kind of module embedded into the Word document. May I ask how to turn it into a macro macro module as a separate one (e.g., "Module 1")?

Many thanks for your help again!

[HansV]

There is no library named Format. But since you have no library whose name starts with MISSING, there must be another cause of the problem. Does it persist if you quit and restart Word? I have tested the code that I posted and it worked as intended on my computer.

[snb]

Here you go:

[snb]

@HansV

There's no need to test whether an application is open to open a certain file with getobject: if the application isn't loaded, it will be, if it is loaded it will stay that way.
The .initialfilename can be used as a filter.
Suggestion:

Code: Select all

Sub M_snb_00()
   On Error GoTo XL90
   
   With GetObject(F_snb(1))
     sn = .sheets(1).Usedrange
     .Close 0
   End With
   MsgBox UBound(sn) & vbTab & UBound(sn, 2)
   
XL90:
End Sub

Code: Select all

Function F_snb(y)
  With Application.FileDialog(3)
    .InitialFileName = Choose(y, "*.xls*", "*.doc*")
    If .Show Then F_snb = .SelectedItems(1)
   End With
End Function

[yanlok1345]

There is no library named Format. But since you have no library whose name starts with MISSING, there must be another cause of the problem. Does it persist if you quit and restart Word? I have tested the code that I posted and it worked as intended on my computer.

Yes. There must be another cause of the problem. It persists if I quit and restart Word. The module cannot be ran in my computer. I tested in three computers, both using Windows 10, Microsoft Office 2019, but in vain.

[HansV]

Does this version work for you?

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 n As String
    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
        ' Get the name
        n = Wsh.Range("A" & r).Value
        ' Get the time
        v = Range("B" & r).Value
        t = 3600 * Left(v, 2) + 60 * Mid(v, 3, 2) + Right(v, 2)
        ' Find the hyperlink corresponding to the name
        For Each hyp In ActiveDocument.Hyperlinks
            If hyp.TextToDisplay = n Then
                ' Get hyperlink address (URL)
                a = hyp.Address
                ' Find position of =Time
                p = InStrRev(a, "=Time")
                ' New URL
                a = Left(a, p) & t
                ' Update hyperlink address
                hyp.Address = a
                Exit For
            End If
        Next hyp
    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

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
    Dim fDialog As FileDialog
    On Error GoTo ERR_HANDLER
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo ERR_HANDLER:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
ERR_HANDLER:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

[SpeakEasy]

Try VBA.Format instead of just Format

[yanlok1345]

Does this version work for you?

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 n As String
    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
        ' Get the name
        n = Wsh.Range("A" & r).Value
        ' Get the time
        v = Range("B" & r).Value
        t = 3600 * Left(v, 2) + 60 * Mid(v, 3, 2) + Right(v, 2)
        ' Find the hyperlink corresponding to the name
        For Each hyp In ActiveDocument.Hyperlinks
            If hyp.TextToDisplay = n Then
                ' Get hyperlink address (URL)
                a = hyp.Address
                ' Find position of =Time
                p = InStrRev(a, "=Time")
                ' New URL
                a = Left(a, p) & t
                ' Update hyperlink address
                hyp.Address = a
                Exit For
            End If
        Next hyp
    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

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
    Dim fDialog As FileDialog
    On Error GoTo ERR_HANDLER
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo ERR_HANDLER:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
ERR_HANDLER:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

Thank you very much for your help. You are truly my savior.

The macro is working this time, but it cannot fulfill the following requirement for replacing the hyperlink:

From: https://xxxxxxx.xxxxx.xxx/xxxxxx/?meeti ... t=Time%201
Replace with: https://xxxxxxx.xxxxx.xxx/xxxxxx/?meeti ... &start=225

[HansV]

There is one error in the code that I posted. Here is the corrected 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 n As String
    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
        ' Get the name
        n = Wsh.Range("A" & r).Value
        ' Get the time
        v = Wsh.Range("B" & r).Value
        t = 3600 * Left(v, 2) + 60 * Mid(v, 3, 2) + Right(v, 2)
        ' Find the hyperlink corresponding to the name
        For Each hyp In ActiveDocument.Hyperlinks
            If hyp.TextToDisplay = n Then
                ' Get hyperlink address (URL)
                a = hyp.Address
                ' Find position of =Time
                p = InStrRev(a, "=Time")
                ' New URL
                a = Left(a, p) & t
                ' Update hyperlink address
                hyp.Address = a
                Exit For
            End If
        Next hyp
    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

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
    Dim fDialog As FileDialog
    On Error GoTo ERR_HANDLER
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo ERR_HANDLER:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
ERR_HANDLER:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

It works for me:

S2467.png

[yanlok1345]

There is one error in the code that I posted. Here is the corrected 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 n As String
    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
        ' Get the name
        n = Wsh.Range("A" & r).Value
        ' Get the time
        v = Wsh.Range("B" & r).Value
        t = 3600 * Left(v, 2) + 60 * Mid(v, 3, 2) + Right(v, 2)
        ' Find the hyperlink corresponding to the name
        For Each hyp In ActiveDocument.Hyperlinks
            If hyp.TextToDisplay = n Then
                ' Get hyperlink address (URL)
                a = hyp.Address
                ' Find position of =Time
                p = InStrRev(a, "=Time")
                ' New URL
                a = Left(a, p) & t
                ' Update hyperlink address
                hyp.Address = a
                Exit For
            End If
        Next hyp
    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

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
    Dim fDialog As FileDialog
    On Error GoTo ERR_HANDLER
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.Add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo ERR_HANDLER:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
ERR_HANDLER:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function

It works for me:


S2467.png

I'm sorry to bother you again. You have already helped me a lot. Your macro is now working with the sample I provided.

However, what I actually need is to use this macro in a confidential document. I first used macro1 to pre-add the hyperlinks:

Code: Select all

Sub PreAdd()

Dim H As hyperlink
Dim Speaker(10000) As String
Dim i As Integer
Dim mtgID As String

mtgID = InputBox("meeting ID。")
If mtgID = Empty Then

MsgBox "no meeting ID。"
  
Exit Sub
Else

i = 0

Selection.HomeKey wdStory

With Selection.Find
    .ClearFormatting
    .Forward = True
    .Format = True
    .Wrap = wdFindStop
    .MatchWildcards = True
    .Text = ""
    .Font.ColorIndex = wdRed
    .Font.BOLD = True
    .Font.Size = 14
    
    Do While .Execute
        Selection.MoveStartWhile cset:="0123456789." & vbCr & vbTab
        Selection.MoveEndWhile cset:="：", Count:=wdBackward
        i = i + 1
        Speaker(i) = Selection.Text
        
        ActiveDocument.Hyperlinks.add Anchor:=Selection.Range, Address:="https://xxxxxxx.xxxxx.xxx.xx/xxxxxx/xx-xx?meetingid=" & mtgID & "&start=Time " & i
        Selection.Collapse wdCollapseEnd
    Loop
    
End With
End If
End Sub

then I tried using your macro to replace the existing hyperlinks one by one. But for some reason, it's not working.

If you have time, may you please help me again to figure out the reason why it cannot replace those links. If not, I fully understand that. Again, thanks a million!