XL 2010 Problème identification de périodes

[Chris24]

Bonjour

Pour une application en vba qui arrive à son terme, je Bug sur un problème d'identification de périodes.
Dans la colonne A j'ai des dates, dans la colonne B j'ai des séries de 1 pour différencier des périodes.
mon problème est d'identifier les différentes périodes par la date de début et date de fin de chacune d'elles.
Je joins un classeur avec des exemples de données et de résultats

Merci de votre aide

 

[Patrice33740]

Bonjour,

Essaies :

Option Explicit
Sub TEST()
Dim dst As Range    ' Destination du résultat
Dim txt As String    ' Texte du résultat
Dim deb As Date    ' Date de début
Dim fin As Date    ' Date de fin
Dim n°L As Long    ' Numéro de ligne
Dim d°L As Long    ' Dernière ligne
Dim pTT As Boolean    ' Plein tarif
Dim ctr As Integer    ' Compteur de résultats

  With Worksheets("Feuil1")
    Set dst = .Range("D2")
    dst.Resize(10, 2).ClearContents     ' à adapter au nombre de résultats
    d°L = .Cells(.Rows.Count, "A").End(xlUp).Row
    n°L = 2
    Do While n°L <= d°L
      pTT = .Cells(n°L, "B").Value = ""
      deb = .Cells(n°L, "A").Value
      Do While n°L <= d°L And pTT = (.Cells(n°L, "B").Value = "")
        fin = .Cells(n°L, "A").Value
        n°L = n°L + 1
      Loop
      txt = Format(deb, "dd/mm/yyyy") & " au " & Format(fin, "dd/mm/yyyy")
      If pTT Then
        dst.Value = "PLEIN TT"
        dst.Offset(0, 1).Value = txt
        ctr = ctr + 1
      Else
        dst.Offset(1, 0).Value = "DEMI TT"
        dst.Offset(1, 1).Value = txt
        ctr = ctr + 1
      End If
      If (ctr Mod 2) = 0 Then
        Set dst = dst.Offset(2, 0)
      End If
    Loop
  End With

End Sub

EDIT : Ajout commentaires

 

[Robert]

Bonjour le fil, le forum,

Patrice a été plus rapide mais comme j'ai planché aussi sur ton problème je me permets de t'envoyer ma solution. Le code ci-dessous travaille sur les colonnes A et B et renvoie le résultat en D2. Si tu veux le modifier il te suffit de redéfinir les variables TV et DEST...
Le code :

Sub TEST()
Dim F1 As Worksheet 'déclare la variable F1 (Feuil1)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des lignes)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Set F1 = Sheets("Feuil1") 'définit l'onglet F1
TV = F1.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
K = 1 'initialise la variable K
ReDim Preserve TL(1 To 2, 1 To K) 'redimensionne le tableau des lignes TL (2 lignes, K colonnes)
TL(1, K) = IIf(TV(2, 2) = "", "PLEIN TT", "DEMI TT") 'définit la valeur de la donnée ligne 1 colonne K de TL en fonction de la donnée ligne 2 colonne 2 de TV
TL(2, K) = "du " & TV(2, 1) & " au " 'définit la valeur de la donnée ligne 2 colonne K de TL en fonction de la date ligne 2 colonne 1 de TV
For I = 2 To UBound(TV, 1) - 1 'boucle sur toutes les lignes I de TV (en partant de la seconde)
    If TV(I, 2) <> TV(I + 1, 2) Then 'condition : si la donnée ligne I colonne 2 de TV est différente de la donnée ligne I+1 colonne 2 de TV
        TL(2, K) = TL(2, K) & TV(I, 1) 'rajoute la date de fin (après le "au ")
        K = K + 1 'incrémente K (ajoute une colonne au tableau ds lignes TL)
        ReDim Preserve TL(1 To 2, 1 To K) 'redimensionne le tableau des lignes TL (2 lignes, K colonnes)
        TL(1, K) = IIf(TV(I + 1, 2) = "", "PLEIN TT", "DEMI TT") 'définit la valeur de la donnée ligne 1 colonne K de TL en fonction de la donnée ligne I+1 colonne 2 de TV
        TL(2, K) = "du " & TV(I + 1, 1) & " au " 'définit la valeur de la donnée ligne 2 colonne K de TL en fonction de la de la date ligne I+1 colonne 1 de TV
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
TL(2, UBound(TL, 2)) = Split(TL(2, UBound(TL, 2)), " au ")(0) & " au " & TV(UBound(TV, 1), 1) 'rajoute la dernière date de fin à la dernière donnée du tableau TL
Set DEST = F1.Range("D2") 'définit la cellule de destination DEST
DEST.Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'renvoie dans DEST le tableau TL transposé
End Sub

 

[Chris24]

@Patrice33740 , Robert

MERCI

les deux solutions fonctionnent parfaitement
Je savais bien qu'il fallait passer par des tableaux mais ceux-ci ne sont pas ma tasse de thé.

Je vais essayer de décortiquer mais surtout de comprendre..... c'est moins sûr

Cordialement