Sub Remplacer()
Dim F1 As Worksheet, F2 As Worksheet
Dim coul&, gras As Boolean, ital As Boolean, x$, plage As Range
Dim cel As Range, r As Range, t$, colore As Boolean, n%, i%, deb%
'---paramètres---
Set F1 = Feuil1 'CodeName, à adapter
Set F2 = Feuil2 'CodeName, à adapter
coul = 3 'rouge
gras = True
ital = False
x = Chr(160)
Set plage = F2.Range("A2", F2.[A65536].End(xlUp))
Application.ScreenUpdating = False
'---sécurité---
F1.[A:A].Replace x, " ", xlPart
'---analyse des textes à modifier---
For Each cel In F1.Range("A1", F1.[A65536].End(xlUp))
'---remplacement encadré par Chr(160)---
For Each r In plage
If InStr(cel, r) Then
If r.Offset(, 2) = "PM" Then
cel = x & r.Offset(, 1) & x & " " & cel
Else
cel = Replace(cel, x & r & x, x & r.Offset(, 1) & x)
cel = Replace(cel, r, x & r.Offset(, 1) & x)
End If
End If
Next
'---coloration des textes entre Chr(160)---
If InStr(cel, x) Then
t = cel & "a"
cel = Replace(cel, x, "")
colore = False
n = 0
For i = 1 To Len(t)
If Mid(t, i, 1) = x Then
colore = Not colore
Else
n = n + 1
If colore Then
If deb = 0 Then deb = n
Else
If deb Then
With cel.Characters(deb, n - deb).Font
.ColorIndex = coul
.Bold = gras
.Italic = ital
End With
deb = 0
End If
End If
End If
Next
End If
Next
End Sub