Option Explicit
Dim Tableau() As String
Dim DossierOK As String
 
'   Dossier contenant les fichiers RTF
Const Dossier = "C:\Word\RTF"
Const CharATrouver = "."
Const CharRemplacement = ":"
 
Public Sub Test()
Dim i As Long
Dim FichiersRTF As String
Dim NomFichier As String
Dim NbFichiers As Long
 
    DossierOK = Dossier
    If Right(DossierOK, 1) <> "\" Then DossierOK = DossierOK + "\"
     
    FichiersRTF = DossierOK + "*.rtf"
    NomFichier = Dir(FichiersRTF)
     
    Erase Tableau
    NbFichiers = 0
    Do While Len(NomFichier) > 0
        NbFichiers = NbFichiers + 1
        ReDim Preserve Tableau(1 To NbFichiers)
        Tableau(NbFichiers) = NomFichier
        NomFichier = Dir()
    Loop
     
    If NbFichiers > 0 Then
        Application.ScreenUpdating = False
            BalayageFichiersRTF
        Application.ScreenUpdating = True
    End If
End Sub
 
Private Sub BalayageFichiersRTF()
Dim i As Long
    ChangeFileOpenDirectory DossierOK
    For i = 1 To UBound(Tableau)
        Documents.Open FileName:=Tableau(i), Format:=wdOpenFormatAuto
        RemplacerDansFichier  
    Next
End Sub
 
Private Sub RemplacerDansFichier()
    ActiveDocument.Select
 
    With Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = CharATrouver
        .Replacement.Text = CharRemplacement
        .Forward = True
        .Execute
    End With
     
    If Selection.Find.Found = False Then
        ActiveDocument.Close
        Exit Sub
    End If
     
    Selection.Find.Execute Replace:=wdReplaceAll
    With ActiveDocument
        .Save
        .Close
    End With
End Sub

 Application.Run "[TemplateName].[ModuleName].[MacroName]
 Par exemple Application.Run "Normal.NewMacros.Macro1"