![]() |
#2
|
||||
|
||||
![]()
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 |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Export Word Data to Excel | anifa | Word | 2 | 12-11-2022 02:51 PM |
![]() |
Flyckten | Word VBA | 5 | 09-03-2018 05:34 AM |
![]() |
lwbarnes | Word VBA | 3 | 06-09-2016 02:47 PM |
Through VBA, export range from Excel to Word | duugg | Word VBA | 0 | 08-24-2009 07:50 PM |
Word to Excel hyperlinks and spaces | gak | Word | 1 | 09-14-2008 08:38 AM |