VBA help for placing hyperlink into Word from Excel

[LionChaser10]

Hello! I am new to VBA so please forgive me, but I need help copying information from Excel into a Word document that is already created and the last item needs to be a hyperlink. The sheet has 3 columns first being the filename, second column is random text, and third column is the full path of the link that needs to be inserted into the Word document as a hyperlink. For clarity, the path is a network drive and the excel is formatted as plain text for the path. There are several thousand Word documents that are already created, but just need to be updated. Everything works perfect with the code, except do not know how to make the text inserted in third column after the "Link: " to be a hyperlink. I have tried mail merge in Word and for this activity does not meet the needs we are aiming for, and this seems to be the best solution. Would you be able to help me? Thank you in advance!

Sub UpdateFiles()
 Dim sFn As String, r As Range, i As Long, x As Long
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    For Each r In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        sFn = ActiveWorkbook.Path & "\" & r.Value & ".docx"
        If Len(Dir(sFn)) > 0 Then
            Set wdDoc = wdApp.Documents.Open(sFn)
            With wdDoc
                .Content.InsertBefore "Link: " & r.Offset(0, 2).Text & Chr(10)
                .Content.InsertBefore "Message: " & r.Offset(0, 1).Text & Chr(10)
                .Content.InsertBefore "Filename: " & r.Text & Chr(10)
                .Close
                i = i + 1
            End With
            Set wdDoc = Nothing
        Else
            x = x + 1
        End If
    Next r
    Set wdApp = Nothing
    MsgBox i & " Files Updated" & Chr(10) & x & " Files Skipped"
End Sub

 

[HongRu]

Try.

Sub UpdateFiles()
 Dim sFn As String, r As Range, i As Long, x As Long
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    For Each r In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        sFn = ActiveWorkbook.Path & "\" & r.Value & ".docx"
        If Len(Dir(sFn)) > 0 Then
            Set wdDoc = wdApp.Documents.Open(sFn)
            With wdDoc
                'delete this line  .Content.InsertBefore "Link: " & r.Offset(0, 2).Text & Chr(10)
                'add the following three lines
                Selection.HomeKey Unit:=wdStory
                .Hyperlinks.Add Anchor:=Selection.Range, Address:=r.Offset(0, 2).Text & Chr(10)
                .Content.InsertBefore "Link: "
                .Content.InsertBefore "Message: " & r.Offset(0, 1).Text & Chr(10)
                .Content.InsertBefore "Filename: " & r.Text & Chr(10)
                .Close
                i = i + 1
            End With
            Set wdDoc = Nothing
        Else
            x = x + 1
        End If
    Next r
    Set wdApp = Nothing
    MsgBox i & " Files Updated" & Chr(10) & x & " Files Skipped"
End Sub

 

[LionChaser10]

Sub UpdateFiles() Dim sFn As String, r As Range, i As Long, x As Long Dim wdApp As New Word.Application Dim wdDoc As Word.Document For Each r In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row) sFn = ActiveWorkbook.Path & "\" & r.Value & ".docx" If Len(Dir(sFn)) > 0 Then Set wdDoc = wdApp.Documents.Open(sFn) With wdDoc 'delete this line .Content.InsertBefore "Link: " & r.Offset(0, 2).Text & Chr(10) 'add the following three lines Selection.HomeKey Unit:=wdStory .Hyperlinks.Add Anchor:=Selection.Range, Address:=r.Offset(0, 2).Text & Chr(10) .Content.InsertBefore "Link: " .Content.InsertBefore "Message: " & r.Offset(0, 1).Text & Chr(10) .Content.InsertBefore "Filename: " & r.Text & Chr(10) .Close i = i + 1 End With Set wdDoc = Nothing Else x = x + 1 End If Next r Set wdApp = Nothing MsgBox i & " Files Updated" & Chr(10) & x & " Files Skipped" End Sub

@HongRu Thank you so much for the reply! The code stops running at "Selection.HomeKey Unit:=wdStory", I am lost at what the issue may be, any thoughts?

 

[HongRu]

try to add one more line "wdDoc.Activate" before "Selection.HomeKey Unit:=wdStory"

Sub UpdateFiles()
 Dim sFn As String, r As Range, i As Long, x As Long
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    For Each r In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        sFn = ActiveWorkbook.Path & "\" & r.Value & ".docx"
        If Len(Dir(sFn)) > 0 Then
            Set wdDoc = wdApp.Documents.Open(sFn)
            With wdDoc
                '.Content.InsertBefore "Link: " & r.Offset(0, 2).Text & Chr(10)
                wdDoc.Activate
                Selection.HomeKey Unit:=wdStory
                .Hyperlinks.Add Anchor:=Selection.Range, Address:=r.Offset(0, 2).Text & Chr(10)
                .Content.InsertBefore "Link: "
                .Content.InsertBefore "Message: " & r.Offset(0, 1).Text & Chr(10)
                .Content.InsertBefore "Filename: " & r.Text & Chr(10)
                .Close
                i = i + 1
            End With
            Set wdDoc = Nothing
        Else
            x = x + 1
        End If
    Next r
    Set wdApp = Nothing
    MsgBox i & " Files Updated" & Chr(10) & x & " Files Skipped"
End Sub

 

[LionChaser10]

try to add one more line "wdDoc.Activate" before "Selection.HomeKey Unit:=wdStory"

Sub UpdateFiles()
 Dim sFn As String, r As Range, i As Long, x As Long
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    For Each r In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        sFn = ActiveWorkbook.Path & "\" & r.Value & ".docx"
        If Len(Dir(sFn)) > 0 Then
            Set wdDoc = wdApp.Documents.Open(sFn)
            With wdDoc
                '.Content.InsertBefore "Link: " & r.Offset(0, 2).Text & Chr(10)
                wdDoc.Activate
                Selection.HomeKey Unit:=wdStory
                .Hyperlinks.Add Anchor:=Selection.Range, Address:=r.Offset(0, 2).Text & Chr(10)
                .Content.InsertBefore "Link: "
                .Content.InsertBefore "Message: " & r.Offset(0, 1).Text & Chr(10)
                .Content.InsertBefore "Filename: " & r.Text & Chr(10)
                .Close
                i = i + 1
            End With
            Set wdDoc = Nothing
        Else
            x = x + 1
        End If
    Next r
    Set wdApp = Nothing
    MsgBox i & " Files Updated" & Chr(10) & x & " Files Skipped"
End Sub

@HongRu Thank you, but it still stops running on "Selection.HomeKey Unit:=wdStory", other thoughts?

 

[HongRu]

Try this.

Sub UpdateFiles()
 Dim sFn As String, r As Range, i As Long, x As Long
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    For Each r In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        sFn = ActiveWorkbook.Path & "\" & r.Value & ".docx"
        If Len(Dir(sFn)) > 0 Then
            Set wdDoc = wdApp.Documents.Open(sFn)
            With wdDoc
                '.Content.InsertBefore "Link: " & r.Offset(0, 2).Text & Chr(10)
                'only add "wdApp" before "Selection.Range"
                .Hyperlinks.Add Anchor:=wdApp.Selection.Range, Address:=r.Offset(0, 2).Text & Chr(10)
                .Content.InsertBefore "Link: "
                .Content.InsertBefore "Message: " & r.Offset(0, 1).Text & Chr(10)
                .Content.InsertBefore "Filename: " & r.Text & Chr(10)
                .Close
                i = i + 1
            End With
            Set wdDoc = Nothing
        Else
            x = x + 1
        End If
    Next r
    Set wdApp = Nothing
    MsgBox i & " Files Updated" & Chr(10) & x & " Files Skipped"
End Sub

 

[LionChaser10]

@HongRu You are amazing, that worked. Thank you so much!