Microsoft 365 Dupliquer automatiquement une ligne selon le nombre de dates

Function eclater(source As Range)
Dim x, s1, t, i&

x = Replace(source(1, 2), "le", "")
x = Replace(x, "et", ",")

s1 = Split(Application.Trim(x), ",")
ReDim t(1 To UBound(s1), 1 To 2)
For i = 1 To UBound(t)
   If s1(i) Like "*du*" Then
      t(i, 1) = source(1, 1)
      t(i, 2) = Trim(s1(i))
   Else
      t(i, 1) = source(1, 1)
      t(i, 2) =trim(s1(i))
   End If
Next i
eclater = t
End Function

Function eclater(source As Range)
Dim x, s1, t, i&
   x = Replace(Replace(source(1, 2), "le", ""), "et", ",")
   s1 = Split(Application.Trim(x), ",")
   ReDim t(1 To UBound(s1), 1 To 2)
   For i = 1 To UBound(t): t(i, 1) = source(1, 1): t(i, 2) = Trim(s1(i)): Next
   eclater = t
End Function

Sub Analyse()

'Si déclaration tardive
     Dim RgEx As Object
     Dim DuAu As Object, Le As Object, Et As Object, Match As Object

'Si "Microsoft VBScript Regular Expressions 5.5" mise en référence
     'Dim RgEx As New VBScript_RegExp_55.RegExp
     'Dim DuAu As VBScript_RegExp_55.MatchCollection, Le As VBScript_RegExp_55.MatchCollection, Et As VBScript_RegExp_55.MatchCollection
     'Dim Match As VBScript_RegExp_55.Match

     Dim Lecture, TbItem(), TbRésultat()
     Dim Chaîne As String, Réf As String, lgn As Long, NbMatches As Integer, i As Integer, k As Long
     Dim Wsh As Worksheet
    
     'Si déclaration tardive
     Set RgEx = CreateObject("VBScript.RegExp")
    
     With RgEx
          .IgnoreCase = True
          .Global = True
          .IgnoreCase = True
          .MultiLine = False
     End With
    
     'Désignation de la feulle à traiter
     On Error Resume Next
     Set Wsh = Application.InputBox(prompt:="Désignez une cellule de la feuille à traiter", Title:="ANALYSE DES PÉRIODES", Type:=8).Parent
     On Error GoTo 0
     If Wsh Is Nothing Then Exit Sub
    
     'Lecture des données dans un Tableau
     With Wsh
          Lecture = .[a1].CurrentRegion.Value
     End With
    
     k = 0
     'Parcourt de toutes les lignes du tableau
     For lgn = 1 To UBound(Lecture, 1)
         
          Réf = Lecture(lgn, 1)        'la référence
          Chaîne = Lecture(lgn, 2)     'la chaîne de date
    
          RgEx.Pattern = "(du \d{2}-\d{2}-\d{2} au \d{2}-\d{2}-\d{2})"   'les dates "du ...  au ..."
          Set DuAu = RgEx.Execute(Chaîne)
         
          RgEx.Pattern = "le (\d{2}-\d{2}-\d{2})"                        'les dates "le ..."
          Set Le = RgEx.Execute(Chaîne)
         
          RgEx.Pattern = "et (\d{2}-\d{2}-\d{2})"                        'les dates "et ..."
          Set Et = RgEx.Execute(Chaîne)
         
          NbMatches = DuAu.Count + Le.Count + Et.Count                   'comptage des dates trouvées
         
          If NbMatches > 0 Then
               'Stockage des périodes et de leur position dans la chaîne dans TbItem
               ReDim TbItem(1 To NbMatches, 1 To 2)
               i = 1
               For Each Match In DuAu
                    TbItem(i, 1) = Match.FirstIndex: TbItem(i, 2) = Match.Value
                    i = i + 1
               Next
                For Each Match In Le
                    TbItem(i, 1) = Match.FirstIndex: TbItem(i, 2) = Replace(LCase(Match.Value), "le ", "")
                    i = i + 1
               Next
               For Each Match In Et
                    TbItem(i, 1) = Match.FirstIndex: TbItem(i, 2) = Replace(LCase(Match.Value), "et ", "")
                    i = i + 1
               Next
               'Tri dans l'ordre des positions dans la chaîne
               tri TbItem, 1, UBound(TbItem, 1)
              
               'Stokage dans le tableau de résultat
               k = k + NbMatches
               ReDim Preserve TbRésultat(1 To 2, 1 To k)
               For i = (NbMatches - 1) To 0 Step -1
                    TbRésultat(1, k - i) = Réf:  TbRésultat(2, k - i) = TbItem(NbMatches - i, 2)
               Next
          End If
         
     Next
    
     'Transposition (si fichier trop grand pour WorksheetFunction.TRANSPOSE)
     ReDim Trans(1 To k, 1 To 2)
     For i = 1 To k
          Trans(i, 1) = TbRésultat(1, i): Trans(i, 2) = TbRésultat(2, i)
     Next
    
     'Ecriture dans une nouvelle feuille
     With Worksheets.Add(After:=Wsh)
          .[a1].Resize(k, 2).Value = Trans
          .Columns("A:B").EntireColumn.AutoFit
     End With
    
End Sub

Sub tri(a, gauc, droi) ' Quick sort J. Boisgontier modifié
     ref = a((gauc + droi) \ 2, 1)
     g = gauc: D = droi
     Do
          Do While a(g, 1) < ref: g = g + 1: Loop
          Do While ref < a(D, 1): D = D - 1: Loop
          If g <= D Then
               temp1 = a(g, 1): temp2 = a(g, 2): a(g, 1) = a(D, 1): a(g, 2) = a(D, 2): a(D, 1) = temp1: a(D, 2) = temp2
               g = g + 1: D = D - 1
          End If
     Loop While g <= D
     If g < droi Then Call tri(a, g, droi)
     If gauc < D Then Call tri(a, gauc, D)
End Sub