Autres (RESOLU)Extraire une année composée de quatre chiffres ("aaaa")

=SIERREUR(--STXT($D2;PETITE.VALEUR(SI(ESTERREUR(ANNEE("1/1/" & STXT($D2;LIGNE(INDIRECT("1:" &(NBCAR($D2)-3)));4)));"";LIGNE(INDIRECT("1:" &(NBCAR($D2)-3))));E$1);4);"")

Function anneeN$(ByVal xs$, ByVal xn As Byte)
Dim i&, dat
   On Error Resume Next
   For i = 1 To Len(xs) - 3
      dat = "": dat = Mid(xs, i, 4)
      If dat Like "####" Then
         dat = CDate("1/1/" & dat)
         If dat <> "" Then
            dat = Year(dat)
            If dat > 1899 Then xn = xn - 1: If xn = 0 Then anneeN = dat: Exit Function
         End If
      End If
   Next i
End Function

Option Explicit
Function ExtraireDate(Rng As Range) As String
    Dim Matches As Object
    Dim Match As Object
    Dim reg As Object
        Set reg = CreateObject("VBScript.RegExp")
    Dim CherchePattern(1 To 2) As Variant
    ' Stock Pattern dans une variable Tableau
    ' Aux Choix de la construction du pattern dans la case du tableau
          CherchePattern(1) = "\b\d{4}\b|d{4}"
          CherchePattern(2) = "(\d{4})" '"(^|\D)(\d{4})(\D|$)"
    ' Exemple ici c'est la case 2 du tableau
    ' Alors l'indice sera la case du tableau
    Dim N As Integer
        N = 2
    Dim i As Integer
' La date
    Dim Txt As String
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set Rng = Rng.Cells(1, 1)
'   Recherche en Ligne :
' ---------------------
            reg.Pattern = CherchePattern(N) ' l'indice N sera = a la case du tableau.
            reg.MultiLine = True: reg.IgnoreCase = False: reg.Global = True: Debug.Print reg.test(Rng.Text)
            Set Matches = reg.Execute(Rng.Text)
            ' Cible de la recherche (Partie du Mots ou chaine recherché !)
            For Each Match In Matches
                'Debug.Print "source >>", Match.Value
'                For i = 0 To Match.SubMatches.Count - 1
'                    Debug.Print "[$" & i + 1 & "]", Match.SubMatches(i)
'                Next i
                    Txt = Txt & " / " & Match.Value
                    'Exit For
            Next Match
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' libération d'objets
    Set Matches = Nothing
    Set Match = Nothing
    Set reg = Nothing
    If Len(Txt) > 4 Then ExtraireDate = Right(Txt, Len(Txt) - 3) Else ExtraireDate = Txt
End Function

Function fourDigits(Rng As Range) As String
    Dim Matches As Object, Match As Object, reg As Object
    Dim CherchePattern
    Set reg = CreateObject("VBScript.RegExp")
    CherchePattern = "(19|20)+(\d{2})"
    reg.Pattern = CherchePattern    '
    reg.MultiLine = True: reg.IgnoreCase = False: reg.Global = True: Debug.Print reg.test(Rng.Text)
    Set Matches = reg.Execute(Rng.Text)
    If Matches.Count > 0 Then fourDigits = Matches(0)
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' libération d'objets
    Set Matches = Nothing
    Set Match = Nothing
    Set reg = Nothing
End Function