Adding a Hyperlink from an Excel file to a Word document using VBA

Question

I am trying to add a hyperlink from Excel to Word.

I tried different anchors including ChBridge & "<< Chime Bridge Hyperlink >>" but all come out as errors.

Also, is there a way to combine the separate text replacements to neaten up the code?

The lookup to ChBridge is a http:\ address and already a hyperlink though that doesn't pull through when replacing the text.

Sub MailMerge()

Dim oWord As Object
Dim oSelection As Object
Dim D1Diff As Double
Dim Site, sAddr, ChBridge As String
    
Set WB = ThisWorkbook.Sheets(Sheets.Count)
Set Sett = ThisWorkbook.Sheets("Settings")
Set RT = ThisWorkbook.Sheets("Hiring Order")

LR = WB.Cells(WB.Rows.Count, "U").End(xlUp).Row
        
For B = 3 To LR Step 1

    Set oWord = CreateObject("Word.Application")
    oWord.Documents.Open "*File Location*"
    oWord.Visible = True

    oWord.ActiveDocument.SaveAs Filename:="Line " & B - 2 & ".docx",     FileFormat:=wdFormatXMLDocument

    'Site & Address Vlookup
    Site = RT.Range("B2")
    sAddr = Application.VLookup(Site, Sett.Range("D1:G3"), 4, 0)

    'Chime Bridge Vlookup
    ChBridge = Application.VLookup(Site, Sett.Range("D1:H3"), 5, 0)

    Set sel = oWord.Selection

    With sel
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        With .Find
            .Text = "<<Chime Bridge Hyperlink>>"
            .Replacement.Text = ChBridge
            .Forward = True
            .Wrap = 1 'wdFindContinue
            .Format = False
            .Hyperlinks.Add Anchor:=.Range, Address:=ChBridge
           sel.Find.Execute Replace:=2  'wdReplaceAll
        End With
    End With

    With sel
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        With .Find
            .Text = "<<Site>>"
            .Replacement.Text = Site
            .Forward = True
            .Wrap = 1 'wdFindContinue
            .Format = False
            sel.Find.Execute Replace:=2  'wdReplaceAll
        End With
    End With

    With sel
        .Find.ClearFormatting
        .Find.Replacement.ClearFormatting
        With .Find
            .Text = "<<Address & Post Code>> "
            .Replacement.Text = sAddr
            .Forward = True
            .Wrap = 1 'wdFindContinue
            .Format = False
            sel.Find.Execute Replace:=2  'wdReplaceAll
        End With
    End With

    oWord.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
    oWord.Quit

Next B

End Sub

Answer 1

I didn't understand all the find and replace, but this should get you started.

See how I declared the variables and assigned them their type.

Also see how I refer to the word application and it's objects

I used Early bound, so you need to add a reference to the Word Object Model ( read this )

Sub MailMerge()
    
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Sheets(Sheets.Count)
    
    Dim settingsSheet As Worksheet
    Set settingsSheet = ThisWorkbook.Sheets("Settings")
    
    Dim hiringOrderSheet As Worksheet
    Set hiringOrderSheet = ThisWorkbook.Sheets("Hiring Order")
    
    Dim lastRow As Long
    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "U").End(xlUp).Row
    
    Dim counter As Long
    For counter = 3 To lastRow Step 1
        
        Dim wordApp As Word.Application
        Set wordApp = Word.Application
        wordApp.Visible = True
        
        Dim wordDoc As Word.Document
        Set wordDoc = wordApp.Documents.Open("C:\Temp\test.docx")
        
        wordDoc.SaveAs Filename:="Line " & counter - 2 & ".docx", FileFormat:=wdFormatXMLDocument
        
        'Site & Address Vlookup
        Dim site As String
        site = hiringOrderSheet.Range("B2").Value
        
        Dim siteAddress As String
        siteAddress = Application.VLookup(site, settingsSheet.Range("D1:G3").Value, 4, 0)
        
        'Chime Bridge Vlookup
        Dim ChBridge As String
        ChBridge = Application.VLookup(site, settingsSheet.Range("D1:H3").Value, 5, 0)
        
        Dim wordContent As Word.Range
        
        Set wordContent = wordDoc.Content
        
        wordContent.Find.ClearFormatting
        wordContent.Find.Replacement.ClearFormatting
        
        With wordContent.Find
            .Text = "<<Chime Bridge Hyperlink>>"
            .Forward = True
            .Wrap = 1
            .Format = False
        End With
        
        wordContent.Find.Execute
        
        While wordContent.Find.Found
            wordContent.Hyperlinks.Add Anchor:=wordContent, Address:=ChBridge, TextToDisplay:=ChBridge
            wordContent.Find.Execute
        Wend
        
        wordDoc.Close SaveChanges:=wdDoNotSaveChanges
        wordApp.Quit
        
    Next counter

End Sub