Microsoft Word - Create Hyperlinks from words, using a reference list
- Thread starter rG-tom
- Start date
indeed, thank you very much!
Just trying to get it working now. the code works fine when i run it on a document with just just a main body, but it crashes with no error when i run it on one with a footnote
The no error bit is infuriating as I have no idea why!
Just trying to get it working now. the code works fine when i run it on a document with just just a main body, but it crashes with no error when i run it on one with a footnote
The no error bit is infuriating as I have no idea why!indeed, thank you very much!
Just trying to get it working now. the code works fine when i run it on a document with just just a main body, but it crashes with no error when i run it on one with a footnote
Hold on a minute, I think I know why! You haven't changed any of the values in the footnote section for the loop have you? edit: nope... just run it again and its all good here. Willing to share the document you are working on? Also make sure your cursor is not in the footnote when running the code.
Want me to build in a quick error handler?
Last edited:
indeed, thank you very much!
Just trying to get it working now. the code works fine when i run it on a document with just just a main body, but it crashes with no error when i run it on one with a footnote
If you haven't fixed it what I would do is set up a watch on all the variable in that last section, then run to cursor after the endnote section at the top of the section that deals with footnotes. Then run it a line at a time checking the variables make sense. when you say the code is crashing does it crash word entirely or run through and just do nothing?
Sorry been stuck in a meeting! It crashed word entirely, have to force close it
Very odd. Can you give me the word doc you are using? Or is that a bit cheeky?
I've so far been just creating a new one and adding a footnote...document has one word and a footnote with one word. I can send if you wish but it is literally just that so far!
Yea that really is odd. And you are just straight up copying and pasting that code? or adding that to your already modified code? Ill do a quick video of it in action on a new document and see if there is anything different we are doing. Ill also just put a single word "word1" in the footnote. Will be later on though. Not 1am later on but later on
I have been testing it with 1, 2, 3 and 10 words in each section but perhaps I missed something.
For the avoidance of any doubt can you replace the code i put earlier with this just in case I put an old version in or something, unlikely but you never know:
Code:
Sub ReplaceLinks()
Dim myexcel As Object
Dim myWB As Object
Set myexcel = CreateObject("Excel.Application")
Set myWB = myexcel.Workbooks.Open("C:\users\vince\desktop\WordHyperLinkTest2.xlsx")
Dim NameIndex As Variant
NameIndex = myWB.Sheets("Data").Range("Names").Value
LinkIndex = myWB.Sheets("Data").Range("Links").Value
Dim wd As Range
Dim itemName As String
Dim wordName As String
Dim linkName As String
Dim bmkNumber As Integer
Dim bmkCount As Integer
Dim lineCount As Integer
Dim bmkIndex As Integer
Dim ftnIndex As Integer
Dim ftnNumber As Integer
Dim ftnCount As Integer
Dim loopCount As Integer
Dim ftnloopCount As Integer
Dim wordCount As Integer
Dim ftnwordCount As Integer
Dim bmkText As String
Dim ftnText As String
Dim fnword As String
Dim ftnfnWord As String
Dim Result() As String
indexCount = 1
lineCount = 1
' Loop through the main body
Do While lineCount < 4 'Set as number of lines in excel spreadsheet.
For Each wd In ActiveDocument.Words
wordName = wd
itemName = (NameIndex(indexCount, 1))
linkName = (LinkIndex(indexCount, 1))
itemName = RemoveWhiteSpace(itemName)
wordName = RemoveWhiteSpace(wordName)
If StrComp(wordName, itemName) = 0 Then
With Selection.Words
ActiveDocument.Hyperlinks.Add Anchor:=wd, Address:=linkName
End With
End If
Next wd
lineCount = lineCount + 1
indexCount = indexCount + 1
Loop
bmkNumber = ActiveDocument.Endnotes.Count
bmkCount = 0
Do While bmkCount < bmkNumber
For Each bmk In ActiveDocument.Endnotes
bmkIndex = bmk.Index
bmkText = ActiveDocument.Endnotes(bmkIndex).Range.Text
Result = Split(bmkText)
wordCount = UBound(Result()) + 2
loopCount = 1
Do While loopCount < wordCount
itemName = (NameIndex(loopCount, 1))
linkName = (LinkIndex(loopCount, 1))
itemName = RemoveWhiteSpace(itemName)
fnword = ActiveDocument.Endnotes(bmkIndex).Range.Words(loopCount).Text
fnword = RemoveWhiteSpace(fnword)
If StrComp(fnword, itemName) = 0 Then
With Selection.Endnotes
ActiveDocument.Hyperlinks.Add Anchor:=ActiveDocument.Endnotes(bmkIndex).Range.Words(loopCount), Address:=linkName
End With
loopCount = loopCount + 1
End If
Loop
Next bmk
bmkCount = bmkCount + 1
Loop
ftnNumber = ActiveDocument.Footnotes.Count
ftnCount = 0
Do While ftnCount < ftnNumber
For Each ftn In ActiveDocument.Footnotes
ftnIndex = ftn.Index
ftnText = ActiveDocument.Footnotes(ftnIndex).Range.Text
Result = Split(ftnText)
ftnwordCount = UBound(Result()) + 2
ftnloopCount = 1
Do While ftnloopCount < ftnwordCount
itemName = (NameIndex(ftnloopCount, 1))
linkName = (LinkIndex(ftnloopCount, 1))
itemName = RemoveWhiteSpace(itemName)
ftnfnWord = ActiveDocument.Footnotes(ftnIndex).Range.Words(ftnloopCount).Text
ftnfnWord = RemoveWhiteSpace(ftnfnWord)
If StrComp(ftnfnWord, itemName) = 0 Then
With Selection.Footnotes
ActiveDocument.Hyperlinks.Add Anchor:=ActiveDocument.Footnotes(ftnIndex).Range.Words(ftnloopCount), Address:=linkName
End With
ftnloopCount = ftnloopCount + 1
End If
Loop
Next ftn
ftnCount = ftnCount + 1
Loop
myWB.Close True
Set myexcel = Nothing
Set myWB = Nothing
End Sub
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Functionboth with my code added and just copy and pasted, and also both on my work machine with 2016 and my home machine with Word 365 build 1905.
It is happening after the body text, as i can see it hyperlink the word in the main body first
It is happening after the body text, as i can see it hyperlink the word in the main body first
Thanks for the files, I now know exactly why so will post the updated code while on the train.
Oh jesus - I totally messed this up didn't I? It's perfect if the words are in order! Should be easy enough to undo my noob mistake. I would have done it on the train but the person beside me decided that nobody needed any peace and quite during the journey. Ill have something for you to play with a little later
The reason it was crashing your word is simply because it got stuck in an infinite loop. Bit like life I guess. I will spend a little time with the wife and chill for a bit then ill give it a little poke.
Last edited:
Oh jesus - I totally messed this up didn't I? It's perfect if the words are in order! Should be easy enough to undo my noob mistake. I would have done it on the train but the person beside me decided that nobody needed any peace and quite during the journey. Ill have something for you to play with a little later
Cheers, and please do this only when you can, I don't need it super urgently
done
I did make quite a few changes in the end and i think if you put end notes in it might crash so does need just 2 variables and then it is good to go.edit: cancel that it should now be done. Let me know how you get on. Also I think there are some variables declared that don't need to be but that can be cleaned up later I also included your row count for the range so you shouldn't have to change that bit now. You probably guessed this bit already but I am not a very good programmer, it's not what I do. I was over complicating things so this one is simpler and does the job better.
Code:
Sub ReplaceLinks()
Dim myexcel As Object
Dim myWB As Object
Set myexcel = CreateObject("Excel.Application")
Set myWB = myexcel.Workbooks.Open("C:\users\vince\desktop\WordHyperLinkTest2.xlsx")
Dim NameIndex As Variant
Dim linkIndex As Variant
NameIndex = myWB.sheets("Data").Range("Names").Value
linkIndex = myWB.sheets("Data").Range("Links").Value
Dim arrayLength As Integer
arrayLength = myWB.sheets("Data").Range("Names").Rows.Count + 1
Dim wd As Range
Dim itemName As String
Dim ftnitemName As String
Dim ftnwordName As String
Dim wordName As String
Dim linkName As String
Dim bmkNumber As Integer
Dim bmkCount As Integer
Dim lineCount As Integer
Dim bmkIndex As Integer
Dim ftnIndex As Integer
Dim ftnNumber As Integer
Dim ftnCount As Integer
Dim loopCount As Integer
Dim ftnloopCount As Integer
Dim wordCount As Integer
Dim ftnwordCount As Integer
Dim bmkText As String
Dim ftnText As String
Dim fnword As String
Dim ftnfnWord As String
Dim Result() As String
indexCount = 1
lineCount = 1
' Loop through the main body
Do While lineCount < arrayLength
For Each wd In ActiveDocument.Words
wordName = wd
itemName = (NameIndex(indexCount, 1))
linkName = (linkIndex(indexCount, 1))
itemName = RemoveWhiteSpace(itemName)
wordName = RemoveWhiteSpace(wordName)
If StrComp(wordName, itemName) = 0 Then
With Selection.Words
ActiveDocument.Hyperlinks.Add Anchor:=wd, Address:=linkName
End With
End If
Next wd
lineCount = lineCount + 1
indexCount = indexCount + 1
Loop
'Loop throught Endnotes
For Each bmk In ActiveDocument.Endnotes
bmkIndex = bmk.Index
bmkText = ActiveDocument.Endnotes(bmkIndex).Range.Text
Result = Split(bmkText)
bmkwordCount = UBound(Result()) + 1
lineCount = 1
bmkIndexCount = 1
Do While lineCount < arrayLength
For Each bmkwd In ActiveDocument.Endnotes(bmkIndex).Range.Words
wordName = bmkwd
itemName = (NameIndex(bmkIndexCount, 1))
linkName = (linkIndex(bmkIndexCount, 1))
itemName = RemoveWhiteSpace(itemName)
wordName = RemoveWhiteSpace(wordName)
If StrComp(wordName, itemName) = 0 Then
With Selection.Endnotes
ActiveDocument.Hyperlinks.Add Anchor:=bmkwd, Address:=linkName
End With
End If
Next bmkwd
lineCount = lineCount + 1
bmkIndexCount = bmkIndexCount + 1
Loop
bmkCount = bmkCount + 1
Next bmk
'Loop through footnotes
For Each ftn In ActiveDocument.Footnotes
ftnIndex = ftn.Index
ftnText = ActiveDocument.Footnotes(ftnIndex).Range.Text
Result = Split(ftnText)
ftnwordCount = UBound(Result()) + 1
lineCount = 1
ftnIndexCount = 1
Do While lineCount < arrayLength
For Each ftnwd In ActiveDocument.Footnotes(ftnIndex).Range.Words
wordName = ftnwd
itemName = (NameIndex(ftnIndexCount, 1))
linkName = (linkIndex(ftnIndexCount, 1))
itemName = RemoveWhiteSpace(itemName)
wordName = RemoveWhiteSpace(wordName)
If StrComp(wordName, itemName) = 0 Then
With Selection.Footnotes
ActiveDocument.Hyperlinks.Add Anchor:=ftnwd, Address:=linkName
End With
End If
Next ftnwd
lineCount = lineCount + 1
ftnIndexCount = ftnIndexCount + 1
Loop
ftnCount = ftnCount + 1
Next ftn
myWB.Close True
Set myexcel = Nothing
Set myWB = Nothing
End Sub
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End FunctionFinally if you copied this before a while ago you might have the footnotes loop before the endnotes loop, for some reason if you do that it crashes and burns when you use endnotes (I re-wrote the footnotes bit as I was being stupid before). despite the name, endnotes come before footnotes or all hell breaks loose.
Last edited:
A pleasure dude, you are very welcome. It is certainly much more efficient than the first attempt, it uses a lot of the same variables all through rather than making a load of new ones for the same thing, it's also down a couple of loops etc. I sat down last night, had a look at it and though "what the hell was I thinking". Logic went out of the window that first iteration.
I was thinking though there are some improvements you could think about like:
1) Case sensitivity- currently its case sensitive but it doesn't have to be.
2) it currently deals with body text, endnotes and footnotes but can easily be adapted for headers and footers which looking at the object model i dont think it covers, it's much the same story for things like from fields and stuff like that.
3) cleaning up unused variables and putting in an error handler should also probably be done. I noticed if you didn't handle endnotes but used endnoted in the document that the code would crash so there might be some other obscure note type that if used might break it as well. (Totally unsure about this or the relationship between footnotes and endnotes so somebody with more knowledge feel free to chime in).
Other than that hopefully it will save you a shed load of time.
Last edited:
Interesting. I'll see what it does with both of those and let you know. It's only possible that they are ignored because there isn't a match between words so should be easy enough to work out what it is doing.
Edit: ok so for whatever reason using the words method which is what we do because it is handy setting the anchor range seems to think that "word-1" is actually 3 words "word", "-" and "1", ill have to see if there is a method to set the separator value. So far I can see there are a couple of ways of fixing it if there isn't a way to do that but really that is the best way to do it
Another way using what we already have, we read the document and count the words into the string array called "result" and that actually works correctly giving us the correct details. The problem then is setting the anchor. Let me have a think about it and a play tomorrow. There must be a way of telling it what a word is.
Last edited:
Thanks! Being able to choose the separator would be ideal as it will likely need to be able to ignore commas and colons as delimiters
I found out that the "-" is a default table separator so a new method was required... Another re-write later, this time it doesn't matter about the separator as it searches a range for a string and just replaces every instance of it. How many different ways can I re-write this before it is bullet proof? It's getting smaller every re-write though.
Code:
Sub ReplaceLinks()
'Open Excel and read in two arrays (Names & Links)
Dim myexcel As Object
Dim myWB As Object
Set myexcel = CreateObject("Excel.Application")
Set myWB = myexcel.Workbooks.Open("C:\users\vince\desktop\WordHyperLinkTest2.xlsx")
Dim NameIndex As Variant
Dim linkIndex As Variant
NameIndex = myWB.sheets("Data").Range("Names").Value
linkIndex = myWB.sheets("Data").Range("Links").Value
Dim arrayLength As Integer
arrayLength = myWB.sheets("Data").Range("Names").Rows.Count + 1
'Set Variables
Dim Rng As Range
Dim itemName As String
Dim linkName As String
Dim lineCount As Integer
Dim bmkIndex As Integer
Dim ftnIndex As Integer
' Loop through the main body
lineCount = 1
Do While lineCount < arrayLength
Set Rng = ActiveDocument.Range
itemName = (NameIndex(lineCount, 1))
linkName = (linkIndex(lineCount, 1))
itemName = RemoveWhiteSpace(itemName)
With Rng.Find
.MatchWildcards = True
Do While .Execute(findText:=itemName, Forward:=False) = True
ActiveDocument.Hyperlinks.Add Anchor:=Rng, _
Address:=linkName, _
SubAddress:="", ScreenTip:="", TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
End With
lineCount = lineCount + 1
Loop
'Loop through Endnotes
lineCount = 1
For Each bmk In ActiveDocument.Endnotes
bmkIndex = bmk.Index
Do While lineCount < arrayLength
Set Rng = ActiveDocument.Endnotes(bmkIndex).Range
itemName = (NameIndex(lineCount, 1))
linkName = (linkIndex(lineCount, 1))
itemName = RemoveWhiteSpace(itemName)
With Rng.Find
.MatchWildcards = True
Do While .Execute(findText:=itemName, Forward:=False) = True
ActiveDocument.Hyperlinks.Add Anchor:=Rng, _
Address:=linkName, _
SubAddress:="", ScreenTip:="", TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
End With
lineCount = lineCount + 1
Loop
Next bmk
'Loop through FootNotes
lineCount = 1
For Each ftn In ActiveDocument.Footnotes
ftnIndex = ftn.Index
Do While lineCount < arrayLength
Set Rng = ActiveDocument.Footnotes(ftnIndex).Range
itemName = (NameIndex(lineCount, 1))
linkName = (linkIndex(lineCount, 1))
itemName = RemoveWhiteSpace(itemName)
With Rng.Find
.MatchWildcards = True
Do While .Execute(findText:=itemName, Forward:=False) = True
ActiveDocument.Hyperlinks.Add Anchor:=Rng, _
Address:=linkName, _
SubAddress:="", ScreenTip:="", TextToDisplay:=Rng.Text
Rng.Collapse wdCollapseStart
Loop
End With
lineCount = lineCount + 1
Loop
Next ftn
'Dispose of Excel
myWB.Close True
Set myexcel = Nothing
Set myWB = Nothing
End Sub
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
Last edited: