VBA to create a hyperlink to a saved document

[tigerdel]

Good afternoon experts

I have created a sheet that saves the details of Quotations in a table
Column B is the Quotation Number
Column C is the Date
Column D is the Client Name
Column E is the Client address first line
Column F is the Value
Column G is my problem

What I want is that as it saves the quotation it places a hyperlink in Column G that the user can click to open the saved quotation

My code to add the quotation details is:

Sub SaveQuotation()
Dim strInv As String
Dim TblRng As Range
Dim ws As Worksheet
Dim tbl As ListObject
Dim MyRange As Range, FindInv As Range
Dim LastRow As Long
Set ws = ActiveSheet
Worksheets("Quotation List").Activate
strInv = Sheets("Quotation").Range("G4")
With ThisWorkbook.Worksheets("Quotation List")
    LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    If LastRow = 4 And .Range("B3") = "" Then LastRow = 3
    Set FindInv = .Range("B3:B" & LastRow).Find(strInv, , xlValues, xlWhole)
    If Not FindInv Is Nothing Then
            MsgBox "Invocie already exists"
            Exit Sub
    End If
    .Cells(LastRow, .Range("QuotationList[Inv. '#]").Column) = Sheets("Quotation").Range("G4")
    .Cells(LastRow, .Range("QuotationList[Date]").Column) = Sheets("Quotation").Range("G5")
    .Cells(LastRow, .Range("QuotationList[Customer]").Column) = Sheets("Quotation").Range("B4")
    .Cells(LastRow, .Range("QuotationList[Address]").Column) = Sheets("Quotation").Range("B5")
    .Cells(LastRow, .Range("QuotationList[Total]").Column) = Sheets("Quotation").Range("G24")
End With
Worksheets("Quotation").Activate
Call SaveQuotationAsPDF
Here is where is goes all wrong
End Sub

The SaveQuotationAsPDF code is:

Private Sub SaveQuotationAsPDF()
Dim FileName As String
With ActiveSheet
FileName = .Range("G4").Value & "-" & .Range("B4").Value
.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
Environ$("OneDrive") & "\MJM Services\2.0 Quotations\pdf Copy\" & FileName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
End Sub

What I really need is the remaining code that will place the hyperlink into Column G so that the user can simply click the link and open the file

Any help will be gratefully received

Kind regards

Derek

 

[Yongle]

Hi Derek
This works for me ...

1. Replace SaveQuotationAsPDF with new procedure below (main amendments are in red)

Private Sub SaveQuotationAsPDF(cell As Range)
    Dim FileName As String, FullPath As String
        With ActiveSheet
            FileName = .Range("G4").Value & "-" & .Range("B4").Value
            FullPath = Environ$("OneDrive") & "\MJM Services\2.0 Quotations\pdf Copy\" & FileName & ".pdf"

            .ExportAsFixedFormat Type:=xlTypePDF, FileName:=FullPath, Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End With
        cell.Parent.Hyperlinks.Add cell, FullPath        
End Sub

2. Amend SaveQuotation
- declare range variable xRng
- set it to the desired target cell
- call SaveQuotationAsPDF and and pass xRng to it

Sub SaveQuotation()
Dim xRng As Range
Dim strInv As String
Dim TblRng As Range
Dim ws As Worksheet
Dim tbl As ListObject
Dim MyRange As Range, FindInv As Range
Dim LastRow As Long
Set ws = ActiveSheet
Worksheets("Quotation List").Activate
strInv = Sheets("Quotation").Range("G4")
With ThisWorkbook.Worksheets("Quotation List")
    LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
    If LastRow = 4 And .Range("B3") = "" Then LastRow = 3
    Set FindInv = .Range("B3:B" & LastRow).Find(strInv, , xlValues, xlWhole)
    If Not FindInv Is Nothing Then
            MsgBox "Invocie already exists"
            Exit Sub
    End If
    .Cells(LastRow, .Range("QuotationList[Inv. '#]").Column) = Sheets("Quotation").Range("G4")
    .Cells(LastRow, .Range("QuotationList[Date]").Column) = Sheets("Quotation").Range("G5")
    .Cells(LastRow, .Range("QuotationList[Customer]").Column) = Sheets("Quotation").Range("B4")
    .Cells(LastRow, .Range("QuotationList[Address]").Column) = Sheets("Quotation").Range("B5")
    .Cells(LastRow, .Range("QuotationList[Total]").Column) = Sheets("Quotation").Range("G24")
    Set xRng = .Cells(LastRow, .Range("QuotationList[Location]").Column)
End With
Worksheets("Quotation").Activate
Call SaveQuotationAsPDF(xRng)

End Sub

 

[tigerdel]

Hey Yongle that amazing - works brilliantly
Is it possible to show text as Open Quotation instead of FullPath?

 

[Yongle]

amend one line

cell.Parent.Hyperlinks.Add cell, FullPath, TextToDisplay:="Open Quotation"

 

[tigerdel]

Thank you

 

[Yongle]

thanks for the feedback