COMPACTAGE D'UNE SÉRIE NUMÉRIQUE

Option Explicit

'---------------------------------------------------------------------------------------
' Procedure : Compacte
' DateTime  : 24/07/2006 20:29
' Author    : Jean-Marc
' Purpose   : Compacte une "collection" de valeurs déja triées en
'             ordre croissant.
' Exemple   : 1,2,3,4,6,9,10,11 ==> 1:4,6,9:11
'
'---------------------------------------------------------------------------------------
'
Public Function Compacte(ByVal cdata As Collection) As String
Dim idx As Long             ' parcours de la collection
Dim vidx As Long            ' valeur (possible) du premier element d'une suite
Dim vc As Long              ' valeur courante
Dim vp As Long              ' valeur precedente
Dim suite As Boolean        ' flag indiquant si l'état courant est dans une suite ou non
Dim tmpResult As String     ' construction du résultat final par concaténations successives

    If cdata.Count = 0 Then     ' si il n'y a pas d'éléments, quitte et retourne une chaine vide
        Exit Function
    End If
    vidx = cdata.Item(1)        ' initialisations, avec le premier élément
    vp = vidx
    For idx = 2 To cdata.Count  ' parcours à partir du second
        vc = cdata.Item(idx)    ' récupération de la valeur courante
        If (vp + 1) = vc Then   ' si elle suit immédiatement la valeur précédente
            suite = True        ' on est dans une suite
        Else
            If suite Then       ' sinon, on regarde si on était dans une suite
                                ' si oui, on concatene la suite, qui part de vidx jusqu'à vp
                tmpResult = tmpResult & "," & CStr(vidx) & ":" & CStr(vp)
            Else                ' si non, on concatene la valeur précédente
                tmpResult = tmpResult & "," & CStr(vp)
            End If
            vidx = vc           ' on réinitialise le premier élément d'une suite potentielle
            suite = False       ' et on reset le flag de suite
        End If
        vp = vc                 ' stockage de la valeur courante dans vp
    Next idx
    If suite Then               ' traitement final, identique à celui qui est dans la boucle
        tmpResult = tmpResult & "," & CStr(vidx) & ":" & CStr(vp)
    Else
        tmpResult = tmpResult & "," & CStr(vp)
    End If
    Compacte = Mid$(tmpResult, 2)   ' élimination de la première virgule
End Function

'---------------------------------------------------------------------------------------
' Procedure : Decompacte
' DateTime  : 25/07/2006 20:15
' Author    : Jean-Marc
' Purpose   : Decompacte une chaine produite par compacte
' Exemple   : 1:4,6,9:11 ==> 1,2,3,4,6,9,10,11
'
'---------------------------------------------------------------------------------------
'
Public Function Decompacte(ByVal data As String) As String
Dim t() As String       ' split la chaine
Dim i As Long           ' parcours des éléments de la chaine
Dim j As Long           ' génération des suites
Dim p As Long           ' cherche les suites grace au signe :
Dim tmpResult As String ' résultat intermédiaire, construite par concatenation

    If data = vbNullString Then ' si chaine vide, retourne vide
        Exit Function
    End If

    t = Split(data, ",")                ' split avec les virgules
    For i = LBound(t()) To UBound(t())  ' parcours
        p = InStr(t(i), ":")
        If p <> 0 Then                  ' est ce une suite (a:b)
            ' si oui, parcours de 'a' à 'b'
            For j = Val(Mid$(t(i), 1, p - 1)) To Val(Mid$(t(i), p + 1))
                tmpResult = tmpResult & "," & CStr(j)
            Next j
        Else
            tmpResult = tmpResult & "," & CStr(t(i))    ' sinon ajoute juste l'élément
        End If
    Next i
    Decompacte = Mid$(tmpResult, 2) ' retourne le resultat, en éliminant la première virgule

End Function

'
' exemple de compactage
'
Private Sub Command1_Click()
Dim cc As Collection
Dim result As String
    
    Set cc = New Collection
    cc.Add (1): cc.Add (2): cc.Add (3): cc.Add (4): cc.Add (6): cc.Add (9): cc.Add (10): cc.Add (11)
    result = Compacte(cc)
    Debug.Print result;: If result = "1:4,6,9:11" Then Debug.Print "   ==> OK" Else Debug.Print "   ==> KO"
End Sub

'
' exemple décompactage
'
Private Sub Command2_Click()
Dim s As String
Dim r As String

    s = "2:5,6,7,9:13,15:17,19,20"
    r = Decompacte(s)
    Debug.Print s & " => " & r
End Sub