View Single Post
 
Old 02-23-2023, 02:27 AM
gmayor's Avatar
gmayor gmayor is offline Windows 10 Office 2019
Expert
 
Join Date: Aug 2014
Posts: 4,144
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

Used in conjunction with Document Batch Processes the following custom process - AddHLinks - will add the links associated with the texts in your Worksheet.
Change the path of the workbook and the worksheet name as appropriate:
Code:
Option Explicit

Const strWorkbook As String = "E:\Path\Example.xlsx"        'The path of the workbook
Const strSheet As String = "Sheet1"        'The name of the worksheet

Sub AddHLinks(oDoc As Document)
Dim Arr() As Variant
Dim i As Long
Dim oRng As Range
Dim sFindText As String
Dim sReplaceText As String
    Arr = xlFillArray(strWorkbook, strSheet)
    For i = 0 To UBound(Arr, 2)
        sFindText = Arr(0, i)
        sReplaceText = Arr(1, i)
        Set oRng = oDoc.Range
        With oRng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            Do While .Execute(findText:=sFindText, _
                              MatchWholeWord:=True, _
                              Forward:=True, _
                              Wrap:=wdFindStop) = True
                oRng.Hyperlinks.Add oRng, sReplaceText
                oRng.End = oRng.End + 1
                oRng.Collapse wdCollapseEnd
                DoEvents
            Loop
        End With
    Next
lbl_Exit:
    Exit Sub
End Sub


Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
'Graham Mayor - http://www.gmayor.com - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long

strRange = strRange & "$]"    'Use this to work with a named worksheet
    'strRange = strRange & "]" 'Use this to work with a named range
    Set CN = CreateObject("ADODB.Connection")

    'Set HDR=NO for no header row
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote