VBA to create hyperlinks from list of words and bookmark names within a word document

[JD226]

Hi all,

I have a report in Word with pre-configured bookmarks within the document. In a separate excel sheet i have a list words in Column A and corresponding pre-configured bookmark name in Column B. What I would like the VBA to be able to do is find the word from column A in the word document and create a hyperlink to its corresponding bookmark from the bookmark name found in column B. Can this be done? Any ideas would help.

Thanks

[macropod]

From what you've described, there doesn't seem to be any need to involve Word in this exercise - all the data you require are already in Excel (i.e. the bookmark names). The words in column A are irrelevant for this. I assume you also have to document's name & path stored somewhere. For a single cell in Excel, the VBA code to do this might be:
ActiveCell.Hyperlinks.Add Anchor:=ActiveCell, Address:=Range("C1").Text, SubAddress:=Range("B1").Text, _
TextToDisplay:=Range("B1").Text, ScreenTip:=Range("C1").Text & " (" & Range("B1").Text & ")"
where 'C1' is the cell address holding the file path & name.

[JD226]

Im sorry. Maybe I wasnt clear. The report in word is where the action needs to take place. So for instance in the excel sheet column A has a word like "Table 1" I need to search the word document for every instance of "Table 1" and change it to an active hyperlink to its respective bookmark (from the bookmark name in Column B.

[macropod]

Try the following macro. It assumes the source workbook is stored in your 'Documents' folder, with the name 'BulkHyperlinks.xls'. Edit as appropriate.

Sub BulkHyperlinkInsertion()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim bStrt As Boolean, iDataRow As Long, bFound As Boolean
Dim xlFList, xlRList, i As Long, Rslt
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkHyperlinks.xls"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
' Test whether Excel is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Excel, so we can close it later.
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Excel.
  bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
bFound = False
With xlApp
  'Hide our Excel session
  If bStrt = True Then .Visible = False
  For Each xlWkBk In .Workbooks
    If xlWkBk.FullName = StrWkBkNm Then ' It's open
      Set xlWkBk = xlWkBk
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
    ' Check if another user has it open.
    If IsFileLocked(StrWkBkNm) = True Then
      ' Report and exit if true
      MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
      If bStrt = True Then .Quit
      Exit Sub
    End If
    ' The file is available, so open it.
    Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
    If xlWkBk Is Nothing Then
      MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
      If bStrt = True Then .Quit
      Exit Sub
    End If
  End If
  ' Process the workbook.
  With xlWkBk.Worksheets(StrWkSht)
    ' Find the last-used row in column A.
    ' Add 1 to get the next row for data-entry.
    iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
    ' Output the captured data.
    For i = 1 To iDataRow
      ' Skip over empty fields to preserve the underlying cell contents.
      If (Trim(.Range("A" & i)) <> vbNullString) And (Trim(.Range("B" & i)) <> vbNullString) Then
        xlFList = xlFList & "|" & Trim(.Range("A" & i))
        xlRList = xlRList & "|" & Trim(.Range("B" & i))
      End If
    Next
  End With
  If bFound = False Then xlWkBk.Close False
  If bStrt = True Then .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
  With ActiveDocument.Range
    With .Find
      .Text = Split(xlFList, "|")(i)
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = True
      .Execute
    End With
    'Change the found text to a hyperlink
    Do While .Find.Found
      .Duplicate.Hyperlinks.Add Anchor:=.Duplicate, SubAddress:=Split(xlRList, "|")(i), _
        TextToDisplay:=Split(xlFList, "|")(i)
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub
'
Function IsFileLocked(strFileName As String) As Boolean
  On Error Resume Next
  Open strFileName For Binary Access Read Write Lock Read Write As #1
  Close #1
  IsFileLocked = Err.Number
  Err.Clear
End Function

[JD226]

So I tried the code you provided and made some slight alterations with turning the screen updating to false and creating the IsFileLocked function. The code starts running and then stops responding. When I recover the word file I can see the code has worked perfectly for the first row of information in the excel file but thats where it appears to stop. I cant seem to determine why its not continuing on to each subsequent row in the excel file. Any thoughts?

[JD226]

Excuse the previous post the alterations I made were because of errors when copying your code over. But while stepping through the code it appears as though once it finds a word and executes the hyperlink addition it gets stuck in an infinite loop from the Do While point.

[macropod]

Try inserting:
.Duplicate.End = .Duplicate.End + 1
before:
.Collapse wdCollapseEnd

[JD226]

No its still goes back to the Do While .Find.Found

[JD226]

I did notice that if it does not find the word it steps back through the 'Process each word from the F/R List' very nicely. I also noticed that it only finds one instance of the word before it continues its endless Do While loop. Im not sure if either of these things shed any light on the issue?

[macropod]

Oops, instead of '.Duplicate.End = .Duplicate.End + 1', that should have been '.End = .End + 1'.

[JD226]

That was is it! Awesome thank you so much!

[JD226]

Unfortunately I ran into another snag. The code sees the word 'Table 1' inside of 'Table 10, Table 11, etc..' and then converts them to Table 1. The same goes for 'Table 2' and all tables in the 20's and so on. Im not quite sure the best way to correct this. Any ideas?

[macropod]

What are 'Table 1', 'Table 10', 'Table 11', etc.?

[JD226]

'Table 1', 'Table 10', 'Table 11', etc. are all part of the xlFlist I have over 30 Tables in this report with references to the tables within the text, some reports may have more. The issue is when the find function finds 'Table 1' in the text it also sees Table 1 within 'Table 10' and for all similarly named tables.

[macropod]

I would have thought the '.MatchWholeWord = True' parameter in the code would prevent that. Try replacing the existing Do While Loop with:

             'Change the found text to a hyperlink
            Do While .Find.Found
                If Not .Characters.Last.Next Like "[0-9A-Za-zÁ-ÿ]" Then
                    .Duplicate.Hyperlinks.Add Anchor:=.Duplicate, SubAddress:=Split(xlRList, "|")(i), _
                    TextToDisplay:=Split(xlFList, "|")(i)
                End If
                .End = .End + 1
                .Collapse wdCollapseEnd
                .Find.Execute
            Loop