Microsoft 365 Dupliquer automatiquement une ligne selon le nombre de dates

thr92

XLDnaute Nouveau
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 o_O

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
 

mapomme

XLDnaute Barbatruc
Supporter XLD
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.

VB:
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:
VB:
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
 

Pièces jointes

  • thr92- ventiler- v1.xlsm
    18.4 KB · Affichages: 10
Dernière édition:

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonjour à tous, Bonjour @thr92

Une solution avec les expressions rationnelles (RegExp).
VB:
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

Code:
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
 

Pièces jointes

  • RegExp.xlsm
    25.4 KB · Affichages: 0
Dernière édition:

Discussions similaires

Réponses
2
Affichages
486

Statistiques des forums

Discussions
311 733
Messages
2 082 015
Membres
101 868
dernier inscrit
pierreselo33