XL 2016 Rechercher une date et reporter une cellule correspondante dans un calendrier

Private Sub Worksheet_Activate()
Dim d As Object, r As Range, x$, i%, c As Range
Application.ScreenUpdating = False
'---adresses des cellules et effacement des cours---
Set d = CreateObject("Scripting.Dictionary")
For Each r In UsedRange
    If r.Formula Like "=Jours*" Then
        d(r.Value) = r(2).Address 'mémorisation de l'adresse
        If Val(r(2)) > 0 Then
            x = Application.Trim(r(2).Value) 'SUPPRESPACE
            For i = 1 To Len(x) + 1
                If Not IsNumeric(Mid(x, i, 1)) And Mid(x, i, 1) <> "+" Then _
                    r(2) = Mid(x, i): Exit For
            Next i
        End If
    End If
Next r
'---entrée des cours---
For Each r In Feuil1.UsedRange.Offset(1, 1)
    If d.exists(r.Value) Then
        Set c = Range(d(r.Value))
        x = Application.Trim(c.Value) 'SUPPRESPACE
        For i = 1 To Len(x) + 1
            If Not IsNumeric(Mid(x, i, 1)) And Mid(x, i, 1) <> "+" Then _
                c = Left(x, i - 1) & r(1, 2 - r.Column) & "+" & Mid(x, i): Exit For
        Next i
    End If
Next r
End Sub