Microsoft 365 Dupliquer automatiquement une ligne selon le nombre de dates

[thr92]

Bonjour à tous,

Je travaille actuellement sur un fichier à utiliser par la suite dans Power BI.

Chaque ligne concerne une plage de travaux avec sa période correspondante mais il y a plusieurs périodes indiquées dans une même cellule.

Exemple:
A1: DEF23_TRS_BDX
B1: Régime applicable, du 24-05-23 au 25-05-23, le 14-06-23, du 12-07-23 au 15-07-23 et 28-10-23

Il faudrait que je puisse créer automatique une ligne par période donnée.
1 ligne A1: DEF23_TRS_BDX B1: du 24-05-23 au 25-05-23
1 ligne A2 : DEF23_TRS_BDX B2 : 14-06-23

etc.. etc..

Auriez-vous une technique me permettant de faire cela ? J'ai dans les 10 000 lignes à traiter

J'ai songé à créer une macro mais ça ne m'est pas familier du tout, il faut encore que je m'y forme.

Merci par avance à vous

 

[Hasco]

Bonjour,

Puisque vos données sont destinées à power bi, pourquoi ne pas le faire avec Power Query, inclus dans votre version office dans l'onglet données.

Un fichier exemple permettrait de vous en dire plus.

Cordialement

 

[mapomme]

Bonjour @thr92, bienvenue sur XLD ,

Une fonction personnalisée en VBA dont le code est dans module1.

Saisir dans une cellule la formule : =eclater(A1:B1)

Solution pour Office 365 seulement.

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

Il a beaucoup plus simple:

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

 

[merinos-BernardEtang]

Salut @thr92 ,

Comme toujours un petit fichier serait bienvenu.


le même query peut être rélisé directemeznt dans Power BI ...

 

[AtTheOne]

Bonjour à tous, Bonjour @thr92

Une solution avec les expressions rationnelles (RegExp).

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

Voir fichier joint
Amicalement
Alain

 

[thr92]

Merci pour vos retours ! Cela m'aide beaucoup.

Bonne journée à tous