Microsoft 365 Formules de haut vol

Function Commune(ByVal x As String) As String
Const separ = "'!""#$%&()*+,-./:;<=>?@[\]{|}¤"
Dim i&, j&
   For i = 1 To Len(separ): x = Replace(x, Mid(separ, i, 1), " "): Next
   x = Application.Trim(x) + " "
   For i = 1 To Len(x) - 2
      If Mid(x, i, 3) = UCase(Mid(x, i, 3)) Then Exit For
   Next i
   For j = i To Len(x)
      If Mid(x, j, 1) <> UCase(Mid(x, j, 1)) Then Exit For
   Next j
   Commune = Application.Trim(Mid(x, i, j - i - 1))
End Function

Function Commune(ByVal x As String) As String
Const separ = "'!""#$%&()*+,-./:;<=>?@[\]{|}¤"
Dim i&, j&
   For i = 1 To Len(separ): x = Replace(x, Mid(separ, i, 1), " "): Next
   x = Application.Trim(x) + " "
   For i = 1 To Len(x) - 2
      If Mid(x, i, 3) = UCase(Mid(x, i, 3)) Then Exit For
   Next i
   For j = i To Len(x)
      If Mid(x, j, 1) <> UCase(Mid(x, j, 1)) Then Exit For
   Next j
   Commune = Application.Trim(Mid(x, i, j - i - 1))
End Function

Function SansCommune(ByVal x As String) As String
Const separ = "'!""#$%&()*+,-./:;<=>?@[\]{|}¤"
Dim i&
   For i = 1 To Len(separ): x = Replace(x, Mid(separ, i, 1), " "): Next
   x = Application.Trim(x) + " "
   x = Application.Trim(Replace(x, Commune(x), " "))
End Function

Sub Extrait()
    Dim DL, T, T2(), M, i, j, Flag, Chaine1$, Chaine2$, IndexT2, Nb%
    Application.ScreenUpdating = False
    DL = Range("B65500").End(xlUp).Row
    T = Range("B2:B" & DL)
    ReDim T2(UBound(T), 2): IndexT2 = 1
    ' Suppression des l' et des d'
    For i = 1 To DL
        On Error Resume Next
        T(i, 1) = Application.Replace(T(i, 1), "l'", "")
        T(i, 1) = Replace(T(i, 1), "d'", "")
    Next i
    ' Séparation des mots en majuscules
    For i = 1 To DL
        Chaine1 = "": Chaine2 = ""
        M = Split(T(i, 1), " ")
        For j = 0 To UBound(M)
            If M(j) = UCase(M(j)) Then
                Chaine1 = Chaine1 & " " & M(j)
            Else
                Chaine2 = Chaine2 & " " & M(j)
            End If
        Next j
        T2(IndexT2, 1) = Chaine2: T2(IndexT2, 2) = Chaine1
        IndexT2 = IndexT2 + 1
    Next i
    ' Suppression mots doublons
    For i = 1 To UBound(T2)
        T2(i, 2) = SupDoublons(T2(i, 2), " ")
    Next i
    ' Rangement matrice résultats
    Range("$D$2").Resize(UBound(T2, 1), UBound(T2, 2)) = T2
End Sub
Function SupDoublons(txt, Optional delim As String = " ") As String
'https://fr.extendoffice.com/documents/excel/2133-excel-remove-duplicate-characters-in-string.html
    Dim x
    'Updateby Extendoffice
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For Each x In Split(txt, delim)
            If Trim(x) <> "" And Not .exists(Trim(x)) Then .Add Trim(x), Nothing
        Next
        If .Count > 0 Then SupDoublons = Join(.keys, delim)
    End With
End Function