Option Explicit
Sub FRWithDefinedHyperlinks()
Dim strDataSourcePath As String, strWorksheet As String
Dim strSQL As String
Dim oVBA_LB As Object
Dim lngIndex As Long
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
Dim oRng As Range
  strDataSourcePath = "D:\FRList.xlsx": strWorksheet = "Sheet1"
  If Dir(strDataSourcePath) = "" Then
    MsgBox "Cannot find the designated workbook: " & strDataSourcePath, vbExclamation
    Exit Sub
  End If
  'Get all data from sheet named "Sheet1", exclude heading row
  strSQL = "SELECT * FROM [" & strWorksheet & "$];"
  'Create a Listbox object to hold data
  Set oVBA_LB = CreateObject("New:{8BD21D20-EC42-11CE-9E0D-00AA006002F3}")
  xlFillList oVBA_LB, strDataSourcePath, "True", strSQL
  Application.ScreenUpdating = False
  Set wdDoc = ActiveDocument
  'Process each word from the F/R List
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWholeWord = True
    .MatchCase = True
    .Wrap = wdFindContinue
    For lngIndex = 0 To oVBA_LB.ListCount - 1
      .Text = oVBA_LB.List(lngIndex, 0)
      While .Execute
         wdDoc.Hyperlinks.Add Anchor:=oRng, _
           Address:=oVBA_LB.List(lngIndex, 2), _
           ScreenTip:=oVBA_LB.List(lngIndex, 3), _
           TextToDisplay:=oVBA_LB.List(lngIndex, 1)
      Wend
    Next
  End With
  Set wdDoc = Nothing: Set oVBA_LB = Nothing
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub
Public Function xlFillList(oListOrComboBox As Object, strWorkbook As String, _
                           bSuppressHeader As Boolean, strSQL As String)
Dim oConn As Object
Dim oRecordSet As Object
Dim lngNumRecs As Long, lngIndex As Long
Dim strWidth As String
Dim strConnection As String
  'Create connection:
  Set oConn = CreateObject("ADODB.Connection")
  If bSuppressHeader Then
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & strWorkbook & ";" & _
                    "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
  Else
    strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & strWorkbook & ";" & _
                    "Extended Properties=""Excel 12.0 Xml;HDR=NO"";"
  End If
  oConn.Open ConnectionString:=strConnection
  Set oRecordSet = CreateObject("ADODB.Recordset")
  'Read the data from the worksheet.
  oRecordSet.Open strSQL, oConn, 3, 1 '3: adOpenStatic, 1: adLockReadOnly
  With oRecordSet
    'Find the last record.
    .MoveLast
    'Get count.
    lngNumRecs = .RecordCount
    'Return to the start.
    .MoveFirst
  End With
  With oListOrComboBox
    .Clear
    'Load the records into the columns of the named list/combo box.
    .ColumnCount = oRecordSet.Fields.Count
    .Column = oRecordSet.GetRows(lngNumRecs)
    strWidth = vbNullString
  End With
Cleanup:
  If oRecordSet.State = 1 Then oRecordSet.Close
  Set oRecordSet = Nothing
  If oConn.State = 1 Then oConn.Close
  Set oConn = Nothing
lbl_Exit:
  Exit Function
End Function

         ' Capture the F/R data.
        For i = 1 To iDataRow
          ' Skip over empty fields to preserve the underlying cell contents.
          If Trim(.Range("A" & i)) <> vbNullString Then
            xlFList = xlFList & "|" & Trim(.Range("A" & i))
            xlRList = xlRList & "|" & Trim(.Range("B" & i))
          End If
        Next


'Some code here


    'Process each word from the F/R List
    With wdDoc
    Options.DefaultHighlightColorIndex = wdYellow
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
        .MatchWholeWord = True
        .MatchCase = True
        .Wrap = wdFindContinue
        For i = 1 To UBound(Split(xlFList, "|"))
          .Text = Split(xlFList, "|")(i)
          .Replacement.Text = Split(xlRList, "|")(i)
          .Execute Replace:=wdReplaceAll
        Next
      End With

Option Explicit
Sub FRandHyperlink()

'Macropod ©2012 from https://www.msofficeforums.com/word-vba/12803-find-replace.html#post34254
'gregmaxey © 2025 from https://www.msofficeforums.com/word-vba/53797-insert-hyperlink-text-replacement-after-find-replace.html

Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList As String, xlRList As String, xlHList As String, i As Long
Dim xlFItem As String, xlRItem As String, xlHItem As String
StrWkBkNm = "C:\Users\calista.hadiwarsito\Documents\Simplifikasi PDR\Macro Testing\Input Template Tester.xlsm"
StrWkSht = "Data Input"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(StrWkBkNm, False, True)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit: Set xlApp = Nothing: Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    'Ensure the worksheet exists
    If SheetExists(xlWkBk, StrWkSht) = True Then
      With .Worksheets(StrWkSht)
        ' Find the last-used row in column A.
        iDataRow = Sheets("Data Input").Cells(.Rows.Count, "D").End(xlUp).Row ' -4162 = xlUp
        ' Capture the F/R data.
        For i = 1 To iDataRow
          ' Skip over empty fields to preserve the underlying cell contents.
          If Trim(.Range("D" & i)) <> vbNullString And Trim(.Range("E" & i)) = "FR" Then
            xlFList = xlFList & "|" & Trim(.Range("D" & i))
            xlRList = xlRList & "|" & Trim(.Range("H" & i))
            xlHList = xlHList & "|" & Trim(.Range("I" & i))
          End If
        Next
      End With
    Else
      MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
    End If
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub

    Set wdDoc = Documents.Open(ThisWorkbook.Path & "\Template PDR 3_full.docx", AddToRecentFiles:=True, Visible:=True)
    'Process each word from the F/R List
    With wdDoc
    Options.DefaultHighlightColorIndex = wdYellow
    End With
      With wdDoc.Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Replacement.Highlight = True
        .MatchWholeWord = True
        .MatchCase = True
        .Wrap = wdFindContinue
        For i = 1 To UBound(Split(xlFList, "|"))
          xlFItem = Split(xlFList, "|")(i)
          xlHItem = Split(xlHList, "|")(i)
          xlRItem = Split(xlRList, "|")(i)
          If xlHItem <> "" Then
            .Text = xlFItem
            While .Execute
                wdDoc.Hyperlinks.Add Anchor:=wdDoc.Range, _
                Address:=xlHItem, _
                ScreenTip:="", _
                TextToDisplay:=xlRItem
            Wend
          Else
            .Text = xlFItem
            .Replacement.Text = xlRItem
            .Execute Replace:=wdReplaceAll
          End If
        Next
      End With
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub