XL 2016 Mettre en gras et souligné la date dans une macro

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim r As Range, texte, couleur, i%, j%
Set r = Intersect(Target, Sh.Range("J1:J" & Sh.Rows.Count))
If r Is Nothing Then Exit Sub
texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR", "RAS", "PAV VETUSTE !", "PAV A CHANGER !")
couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64), RGB(0, 0, 0), RGB(255, 0, 0), RGB(255, 0, 0))
With r.Font: .ColorIndex = xlAutomatic: .Bold = True: .Underline = xlUnderlineStyleSingle: End With 'RAZ
For Each r In r 'si entrées multiples (copier-coller)
    For i = 0 To UBound(texte)
        j = InStr(r, texte(i))
        If j Then
            With r.Characters(j, Len(texte(i))).Font
                .Color = couleur(i)
                .Bold = True
                .Underline = xlUnderlineStyleSingle
            End With
        End If
Next i, r

End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim R As Range
    Set R = Intersect(Target, Sh.Range("J1:J" & Sh.Rows.Count))
    If R Is Nothing Then Exit Sub

Dim Texte:        Texte = Array("BORNES VERRE", "BORNES PAPIERS", "BORNES EML", "BORNES OMR", "RAS", "PAV VETUSTE !", "PAV A CHANGER !")
Dim Couleur:    Couleur = Array(RGB(84, 130, 53), RGB(47, 117, 181), RGB(191, 143, 0), RGB(64, 64, 64), RGB(0, 0, 0), RGB(255, 0, 0), RGB(255, 0, 0))
Dim Gras:          Gras = Array(False, False, False, False, False, False, False)
Dim Souligné:  Souligné = Array(False, False, False, False, False, False, False)
Dim W As Variant
Dim I As Integer
Dim J As Integer

    For Each R In R 'si entrées multiples (copier-coller)
        For I = 0 To UBound(Texte)
            J = InStr(R, Texte(I))
            If J Then
                With R.Characters(J, Len(Texte(I))).Font
                    .Color = Couleur(I)
                    .Bold = Gras(I)
                    .Underline = Souligné(I)
                End With
            End If
        Next
        ' On va traquer les dates ( il peut en avoir plusieurs dans la chaine )
        W = R
        For I = 1 To Len(R)
            If Not (Mid(R, I, 1) = "/" Or IsNumeric(Mid(R, I, 1))) Then Mid(W, I, 1) = " "
        Next
        While InStr(W, "  "): W = Replace(W, "  ", " "): Wend
        J = 0
        For Each W In Split(Replace(Trim(W), " ", vbLf), vbLf)
            If IsDate(W) Then
                J = InStr(J + 1, R, W)
                With R.Characters(J, Len(W)).Font
                    .Bold = True
                    .Underline = xlUnderlineStyleSingle
                End With
            End If
        Next
    Next

End Sub