Percentage not carrying over.

With the section & Range("Q2").Value & needs to pull a percentage from the sheet in question however when ever it pulls though to email it comes as a decimal number and not a percentage.

Could anyone please help me solve this. thanks.

Sub Send_On_Road_Data()
'
    Sheets("On Road Performance").Select
'
    With Sheets("On Road Performance")
        If .Range("B3") = "" Then
            MsgBox "Please Insert On Road Performance Data"
            Exit Sub
        End If
    End With
'
    Sheets("On Road Performance").Select
    Range("B3").Select
'
Dim strto As String, strsub As String, strbody As String, Fnt As String
Dim rng As Range
Set rng = Sheets("On Road Performance").Range("OnRoadPerformance[#All]").SpecialCells(xlCellTypeVisible)
strto = " "
strcc = ""
strsub = "On Road Performance - " & Date - 1
strbody = "Morning All," & "<br>" & _
        "" & "<br>" & _
        "Please find bellow the On Road Performance for yesterday. Your average FDDS was " & Range("Q2").Value & "." & "<br>" & _
        ""
            
Fnt = "<p style='font-family:Calibri;font-size:11.0pt'>"
With CreateObject("Outlook.Application").Createitem(0)
    .Display
    .To = strto
    .Cc = strcc
    .Subject = strsub
    .HTMLBody = Fnt & strbody & RangetoHTML(rng) & .HTMLBody
    '.Send
End With
'
    Range("B2").Select
'
Dim wb As Workbook
Set WorkRng = Range("A1:P400")
WorkRng.Copy
Set wb = Workbooks.Add
With wb
    ActiveSheet.Paste
    .SaveAs "Test File" & "\" & "On Road Performance - " & Range("C3").Value & " - " & Format(Date, "dd.mm.yyyy") & ".xlsx"
    .Close
End With
'
MsgBox "Congratulations, Data Saved!"
'
End Sub

Function RangetoHTML(rng As Range)
Dim fso As Object, ts As Object
Dim TempFile As String, TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
    SourceType:=xlSourceRange, _
    Filename:=TempFile, _
    Sheet:=TempWB.Sheets(1).Name, _
    Source:=TempWB.Sheets(1).UsedRange.Address, _
    HtmlType:=xlHtmlStatic)
    .Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                        "align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function