View Single Post
 
Old 02-23-2023, 03:54 AM
syl3786 syl3786 is offline Windows 10 Office 2019
Advanced Beginner
 
Join Date: Jan 2023
Posts: 97
syl3786 is on a distinguished road
Default

Quote:
Originally Posted by gmayor View Post
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
Thank you Gmayor! May I ask if I can just use the Macro but not install any add-ins? As I am not allowed to install any add-ins in company's computer.
Reply With Quote