copy values as links to corresponding columns

I would like to add a final stage to the macro below so it will do the following;

Sub SendEmail()
'///Set up the Excel variables.
    Const MsgSignature As String = "Supplier Relationship Team"
    Const sSubj As String = "Supplier Meeting Action Points"
    Dim rCl As Range, rRng As Range
    Dim OLApp As Object, olMailItm As Object
    Dim iCnt As Integer
    Dim sTo As String, sMsg As String

    '///Create the Outlook application and the empty email.
    Set OLApp = CreateObject("Outlook.Application")
    Set olMailItm = OLApp.CreateItem(0)


    sMsg = "Hi,<br><br>" & _
           "Please could you complete the action points found on the supplier meeting report (link below) <br><br>" & _
           "Once you have completed your action points please change the status from the drop down list found in column C/D and leave any relevant comments in the STAKEHOLDER COMMENTS column.<br><br>" & _
           "Once completed please click the 'close' button found under the SUPPLIER MEETINGS tab at the top of the page.:<br><br>" & _
           "If you have any questions regarding your action points please contact the appropriate category manager found in cell E6 of the sheet.:<br><br>" & _
           "Please open the meeting report using the link below and select the meeting report link called " & Range("B2") & " found in column E<br><br>" & _
           "Click on the link below to open the file (Click 'Ok' and 'Continue' to all prompts when opening the file) :<br><br> " & _
           "<A HREF=""file://" & ActiveWorkbook.FullName & _
           """>Link to the file</A>" & _
           "<br><br>Regards," & _
           "<br><br>" & MsgSignature

    '/// create list of recipients

    Set rRng = Range("B86:B93")

    With olMailItm

        For Each rCl In rRng.Cells
            If rCl.Value > 0 Then
                If sTo = "" Then
                    sTo = rCl.Value
                Else
                    sTo = sTo & ";" & rCl.Value
                End If
                iCnt = iCnt + 1
            End If
        Next rCl

        If iCnt < 2 Then
            MsgBox "You nave not entered any recipients.", vbCritical, MsgSignature
            Exit Sub
        End If

        .To = sTo
        .Subject = sSubj
        .HTMLBody = sMsg
        .Display
        .Send
    End With

    '///Clean up the Outlook application.
    Set olMailItm = Nothing
    Set OLApp = Nothing

    Exit Sub

Errhandler:
    MsgBox Error(Err)
    Resume Next

End Sub

Select allOpen in new window

1. Copy all values (including blank cell values) from the range A14:E18 and paste under the relevant column headings found in sheet result_example

The values and blank values should be pasted as links with the original formatting.

Example Result: The sheet result_example provides a prototype result of what should be achieved when the macro is run.

Note 1: The  columns have the same headings (except F)  but are not in the same order/layout on the destination sheet therefore a straight copy and paste will not be possible, instead cell values should be matched to the corresponding columns headings.

Note 2: The reason the values must be pasted as links is because the data in the original worksheet will be updated over time. Blank cells may also be populated at a later date.

Taking the attached example you will notice that cell values copied from row 18 on the original sheet are all blank . This means that the cells in the bottom row (6) in the destination sheet will be completely blank( except column  F)  but will be linked. This means that if the blank cells in row 18 on the original sheet are populated then the blank cells in row 6 on the destination sheet will also be populated.

I have highlighted the blank cells red and provided an explanation of the required mechanism in a key on the attached sheet.

Note 3:

Column F will be populated with a hyperlink. The hyperlink will be generated using coding - An example of this is found in the code snippet below. Ultimately the value of the hyperlink will be the same as the worksheet name i.e. Sterling 09.07.2015. This hyperlink will send the user back to the original sheet. Note all five rows will be populated with this same hyperlink even if the other cells in the rows are blank.

Sub ImportForm()
    Dim wbLog As Workbook
    Dim MainSht As Worksheet, LogSht As Worksheet, CopySht As Worksheet
    Dim rData As Range
    Dim NewRw As Long
    Dim sFil As String, sTitle As String, sWb As String
    Dim iFilterIndex As Integer



    Set MainSht = ActiveSheet
    ' Set up list of file filters
    sFil = "Excel Files (*.xl*),*.xl*"
    ' Display *.xls by default
    iFilterIndex = 1
    ' Set the dialog box caption
    sTitle = "Select  File to Zip"
    ' Get the filename
    With Application
        sWb = .GetOpenFilename(sFil, iFilterIndex, sTitle)
        Set wbLog = Workbooks.Open(sWb)
        '        On Error GoTo err_handler
        .ScreenUpdating = False
        .DisplayAlerts = False

        Set LogSht = Worksheets("Meetings.Task.Status.Log")

        MainSht.Copy After:=wbLog.Sheets(wbLog.Sheets.Count)
        ActiveSheet.Name = ActiveSheet.Range("B2").Value
        Set CopySht = ActiveSheet

        Set rData = LogSht.Range("A1").CurrentRegion.Offset(1)
        NewRw = rData.Rows.Count + 1

        CopySht.Range("e6").Copy
        LogSht.Select
        'manager
        NewRw = rData.Rows.Count
        rData.Cells(NewRw, 1).Select
        ActiveSheet.Paste Link:=True
        'company name
        CopySht.Range("B1").Copy
        rData.Cells(NewRw, 2).Select
        ActiveSheet.Paste Link:=True
        'date of meeting
        CopySht.Range("B7").Copy
        rData.Cells(NewRw, 3).Select
        ActiveSheet.Paste Link:=True
        CopySht.Range("E2").Copy
        rData.Cells(NewRw, 4).Select
        ActiveSheet.Paste Link:=True
        'add link
        rData.Cells(NewRw, 5).Select
        LogSht.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
                              "'" & CopySht.Name & "'!A1", TextToDisplay:=CopySht.Name



clean_up:
        .ScreenUpdating = True
        .CutCopyMode = False
        .DisplayAlerts = True
    End With

    Exit Sub
err_handler:
    MsgBox "No file selected", vbCritical
    Resume clean_up
End Sub

Select allOpen in new window

Note 4:

The code will be run on multiple sheets. Each time data from a new sheet is added it should be added to the next available row and not over the current data.
EmailIt-macro.xlsm