#1
|
|||
|
|||
Add hyperlinks to same texts in different sequence
Hi community,
I would like to ask if it is possible to use word macros to add hyperlinks to same texts in different sequence. For example, I have a conversation content in a word document: Speaker 1: Hello I am ABC Speaker 2: Please sit down. Speaker 1: OK Speaker 2: Please introduce yourself in 1 minute. Speaker 1: I am XXX, I graduated from XXX...... Different hyperlinks need to be added to "speaker 1" and "speaker 2". However, "speaker 1" and "speaker 2" happened multiple times in a word document. General mailmerge hyperlink word macro or addins cannot identify the sequence of them. Is there any method to automatically add different hyperlinks to the same texts but in different sequence according to the excel file? I tried to draft the code as follows: Code:
Sub AddHyperlinks() ' Open the Excel file containing the hyperlinks Dim xlApp As Excel.Application Dim xlWB As Excel.Workbook Set xlApp = CreateObject("Excel.Application") Set xlWB = xlApp.Workbooks.Open("C:\Path\To\Hyperlinks.xlsx") ' Loop through each occurrence of "Secretary" in the document Dim doc As Document Set doc = ActiveDocument Dim rng As Range Set rng = doc.Content Dim counter As Integer counter = 1 Do While rng.Find.Execute("Secretary", MatchWholeWord:=True) ' Add the hyperlink to this occurrence of "Secretary" Dim hyperlink As String hyperlink = xlWB.Sheets(1).Cells(counter, 1).Value Dim linkRange As Range Set linkRange = rng.Duplicate linkRange.Collapse Direction:=wdCollapseStart linkRange.MoveEndUntil Cset:=" " rng.Hyperlinks.Add Anchor:=linkRange, Address:=hyperlink counter = counter + 1 Loop ' Close the Excel file xlWB.Close xlApp.Quit End Sub |
#2
|
||||
|
||||
You need to process each row of the Worksheet in turn and look for the first unlinked version of the name and process only that one e.g. as follows. Ensure there are no empty cells in the used area of the worksheet, which can be open or closed when the code is run.
Code:
Option Explicit Const strWB As String = "C:\Path\To\Hyperlinks.xlsx" Const strSheet As String = "Sheet1" Sub AddHyperlinks() Dim oDoc As Document Dim oRng As Range Dim Arr() As Variant Dim i As Long Dim sName As String, sLink As String Set oDoc = ActiveDocument Arr = xlFillArray(strWB, strSheet) For i = 0 To UBound(Arr, 2) sName = Arr(0, i) sLink = Arr(1, i) Set oRng = oDoc.Range With oRng.Find .ClearFormatting .Replacement.ClearFormatting Do While .Execute(findText:=sName) If oRng.Hyperlinks.Count = 0 Then oRng.Hyperlinks.Add oRng, sLink, , , sName Exit Do End If Loop End With Next i 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 |
#3
|
|||
|
|||
Quote:
|
Tags |
hyperlinks, word macro |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
How to use Word Macros to mail merge hyperlinks to the texts in textboxes? | syl3786 | Word VBA | 4 | 03-03-2023 10:43 PM |
Word Macro: How to automatically add hyperlinks to timestamp texts? | loklokpanda | Word VBA | 0 | 02-12-2023 09:22 AM |
Formula to add +1 to a sequence | Benali | Excel | 6 | 05-05-2020 03:47 AM |
Vlook up multiple sequence | Cryken | Excel | 4 | 01-31-2017 08:45 AM |
Sequence problem | Pecoflyer | Excel | 2 | 01-10-2017 09:34 AM |