Microsoft Office Forums - View Single Post - [Solved] Interesting hyperlink macro problem

macropod · 03-11-2012, 09:50 PM

Hi DobberHockey,

The coding for what you describe isn't exactly trivial. Try the following Word macro and see how it goes. I can't test it as I don't have anything like your document & Excel workbook setup to do so with. You'll have to make a number of changes to the macro's Excel workbook references. You'll need to change:
StrWkBkNm = "C:\Users\Username\Documents\Workbook Name.xls"
to point to your workbook;
With xlWkBk.Worksheets("Players")
to point to the correct worksheet; and the
'A' and 'B' references in the two occurrences of .Range("A" & i) and .Range("B" & i)
to point to the columns containing the player names and their web pages, respectively.

If you add the code to Word's Normal template, or to the template for your columns/articles it should be available for all of your columns/articles.

Code:

Option Explicit
 
Sub BulkHyperlinkInsertion()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String
Dim iDataRow As Long,  xlFList As String, xlHList As String, i As Long
StrWkBkNm = "C:\Users\Username\Documents\Workbook Name.xls"
Const StrWkSht As String = "Players"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    'Ensure the worksheet exists
    If SheetExists(xlWkBk, StrWkSht) = True Then
      With .Worksheets(StrWkSht)
        ' Find the last-used row in column A.
        iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        ' Capture the F/R data.
        For i = 1 To iDataRow
          ' Skip over empty fields to preserve the underlying cell contents.
          If Trim(.Range("A" & i)) <> vbNullString Then
            xlFList = xlFList & "|" & Trim(.Range("A" & i))
            xlRList = xlHList & "|" & Trim(.Range("B" & i))
          End If
        Next
      End With
    Else
      MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
    End If
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub 
'Process each word from the Player 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, Address:=Split(xlHList, "|")(i)
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub
 
Function SheetExists(xlWkBk As Object, SheetName As String) As Boolean
Dim i As Long: SheetExists = False
With xlWkBk
  For i = 1 To .Sheets.Count
    If .Sheets(i).Name = SheetName Then
      SheetExists = True:   Exit For
    End If
  Next
End With
End Function