Mettre quelques mots d'une chaine en majuscule

Function MajusculeSpeciale(Chaine As String) As String
'si tu enlèves la rem devant Application.Volatile
'   tu enlèves la rem devant If ActiveWorkbook.Name ...
'If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Function
'Application.Volatile

Dim oRegExp As Object, Matches As Object, I As Byte
Chaine = LCase(Chaine)
Set oRegExp = CreateObject("vbscript.regexp")
With oRegExp
  .Global = True
  .Pattern = "[a-zéèàëöôûüîï]{3,}"
   Set Matches = .Execute(Chaine)
End With
For I = 0 To Matches.Count - 1
 Chaine = Replace(Chaine, Matches.Item(I), Application.WorksheetFunction.Proper(Matches.Item(I)))
Next I
MajusculeSpeciale = Trim(Chaine)
Set oRegExp = Nothing: Set Matches = Nothing
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Column = 2 Or Target.Column = 3 Then
        Target.Value = MajusculeSpeciale(Target.Value)
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Not (Target.Column = 2 Or Target.Column = 3) Then Exit Sub
Dim oRegExp As Object, Matches As Object, I As Byte
Chaine = LCase(Target.Value)
Set oRegExp = CreateObject("vbscript.regexp")
With oRegExp
  .Global = True
  .Pattern = "[a-zéèàëöôûüîï]{3,}"
   Set Matches = .Execute(Chaine)
End With
For I = 0 To Matches.Count - 1
 Chaine = Replace(Chaine, Matches.Item(I), Application.WorksheetFunction.Proper(Matches.Item(I)))
Next I
Target.Value = Trim(Chaine)
Set oRegExp = Nothing: Set Matches = Nothing
End Sub

Function MajusculeSpeciale(Rng As String) As String
If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Function
Dim M$, I%, I1%, I2%, II%, LM%, MaxMot%, Majus$, Minus$
'tout en minus et 1'car de chaque mot en majusc
M$ = Application.Proper(LCase(Rng))
I1% = 0: I2% = 1: MaxMot% = 3 'remet en minus les mots de 1à3 car maxi
Do
 I1% = InStr(I2%, M$, " "): If I1% = 0 Then Exit Do
 I2% = InStr(I1% + 1, M$, " ")
 I% = I2% - I1% - 1: If I% <= 0 Then Exit Do
 If I% > 0 And I% <= MaxMot% Then Mid(M$, I1% + 1, 1) = LCase(Mid(M$, I1% + 1, 1))
Loop

I% = 0 'remet en minus 1'car des mots avec une apostrophe
Do: I% = InStr(I% + 1, M$, "'"): If I% = 0 Then Exit Do
 Mid(M$, I% - 1, 1) = LCase(Mid(M$, I% - 1, 1))
Loop

LM% = Len(M$) 'remet en minus le 1'car après chiffre
For I% = 1 To LM%
 If IsNumeric(Mid(M$, I%, 1)) Then
    For II% = I% + 1 To LM%
     If Not IsNumeric(Mid(M$, II%, 1)) And Mid(M$, II%, 1) <> " " Then
        Mid(M$, II%, 1) = LCase(Mid(M$, II%, 1)): I% = II%: Exit For
     End If
    Next
 End If
Next
MajusculeSpeciale = M$
End Function