macro for replacing different text

I have labels that have date on them (product date and exp. date) is it possible to create a macro that finds and replace this set of dates with one click? i tried to record a macro to paste the dates but it dosent run correctly (mostly the deleting part of it) . 

What i have to do to be more precise is this : i have a number of products and i must print label forr them for example , label A with date1:2017-10 date2:2018-09 label B with date1:2015-8 date2:2017-07 and so on, all date are going to replaced with the same dates for example label A with date1:2017-11 date2:2018-10 label B with date1:2017-11 date2:2018-10  . Because it is usually around 30 or so labels i whould like to create a macro that replaces if possible all opend files at once or at least with one click at each file. 

I found this

' find toFind in str and replace with toReplace
Public Function FindReplace(ByVal str As String, ByVal toFind As String, ByVal toReplace As String) As String
    Dim i As Integer
    For i = 1 To Len(str)
        If Mid(str, i, Len(toFind)) = toFind Then   ' does the string match?
            FindReplace = FindReplace & toReplace               ' add the new replacement to the final result
            i = i + (Len(toFind) - 1)               ' move to the character after the toFind
        Else
            FindReplace = FindReplace & Mid(str, i, 1)        ' add a character
        End If
    Next i
End Function

Public Sub TextTranslate()
    Dim s As Shape
    ActiveDocument.BeginCommandGroup "Text Translate"
    For Each s In ActiveDocument.ActivePage.Shapes
        If s.Type = cdrTextShape Then
            s.Text.Story = FindReplace(s.Text.Story, "Andorra", "Andorre")
            s.Text.Story = FindReplace(s.Text.Story, "Albania", "Albanie")
        End If
    Next s
    ActiveDocument.EndCommandGroup
End Sub

but didnt seeem to work ( i replace Andorra with date1 and Andorre with the date that i want to be)