losing zeros following decimal point

I am sending data from an excel sheet to a word template (Office 2007). In the excel sheet, 2 of the fields are formatted as Euro currency with 2 decimal points and show as €111.00. When they copy to the word document they are reduced to €111 and the 2 zeros are missing. I can’t change the template to [bookmark].00 because sometimes there is numbers after the decimal point, ie, €111.69.

Any advice please.

Sub bookingform()
  Dim wA As Object 'Word.Application
  Dim wD As Object 'Word.Document
  Dim wR As Object 'Word.Range
  Dim OpenMark As Long, CloseMark As Long
  Dim FieldName As String
  Dim thisrow As Range, Header As Range
  'We populate the items from this row
  Set thisrow = ActiveCell.EntireRow
  'As example:
  ' It is possible to open a file and get the object
  ' The OS choose the associate application for us
  On Error Resume Next
  'Get the pointer to Word
  Set wA = GetObject(, "Word.Application")
  If wA Is Nothing Then
    'Open it
    Set wA = CreateObject("Word.Application")
    If wA Is Nothing Then
      MsgBox "Word is not accessible"
      Exit Sub
    End If
    wA.Visible = True 'Optional
  End If
  On Error GoTo 0
  'Create a new file from template
  Set wD = wA.Documents.Add("C:\Users\Me\Booking_Form.doc")
  'Get the whole content
  Set wR = wD.Content
  'Search for a [
  Do While wR.Find.Execute("[")
    'Note: Find.Execute modifies the object wR to the location!
    'Remember the start position
    OpenMark = wR.Start
    'Expand to the end of the document
    wR.SetRange wR.End, wD.Content.End
    'Search for a ]
    If wR.Find.Execute("]") Then
      'Remember the end position
      CloseMark = wR.End
      'Get the range, including []
      wR.SetRange OpenMark, CloseMark
      'Get the text inside
      FieldName = Mid(wR.Text, 2, Len(wR.Text) - 2)
      'Search for that text in our top row
      Set Header = Rows(1).Find(FieldName, LookIn:=xlValues, LookAt:=xlWhole)
      'Found?
      If Not Header Is Nothing Then
        'Replace the text
        wD.Range(OpenMark, CloseMark).Text = Intersect(thisrow, Header.EntireColumn)
      End If
      'Expand to the end of the document
      wR.SetRange wR.End, wD.Content.End
    End If
  Loop
  
End Sub