Hola chicos, esta es mi ultima funcion que sirve para simplificar arrays numéricos.
En realidad es un reto que me puso mi maestro BlackZer0X!

Añadir mi clase cCollectionEx.cls

'=========================================================
' º Function : Abbreviate_Numeric_Array
' º Author   : Mr. Frog ©
' º Mail     : vbpsyke1@mixmail.com
' º Recommended Websites :
'       http://blog.visual-coders.com.ar/
'       http://InfrAngeluX.Sytes.Net/
'=========================================================
Option Explicit
Option Base 0
 
Rem Añadir mi clase cCollectionEx.cls
 
Public Function Abbreviate_Numeric_Array(ByRef vNumberList() As Variant) As cCollectionEx
If (Not vNumberList) = -1 Then Exit Function
Dim cExTemp                                         As New cCollectionEx
Dim lActualNumber                                   As Variant
Dim lToTalNumbers                                   As Long
Dim Q                                               As Long
Dim W                                               As Long
    lToTalNumbers = UBound(vNumberList())
    If lToTalNumbers > 2 Then
        Do While Q <= lToTalNumbers
            lActualNumber = vNumberList(Q)
            W = 0
            If (Q < lToTalNumbers) Then
                Do While (vNumberList(Q) + 1 = vNumberList(Q + 1)) Or _
                         (vNumberList(Q) = vNumberList(Q + 1))
                    Q = Q + 1
                    W = W + 1
                Loop
            End If
            With cExTemp
                If W > 1 Then
                    .Add lActualNumber & "~" & vNumberList(Q)
                Else
                    .Add lActualNumber
                End If
            End With
            If Not (W = 1) Then Q = Q + 1
        Loop
        Set Abbreviate_Numeric_Array = cExTemp
    End If
End Function

Ejemplo:

Private Sub Form_Load()
Dim Q                                   As Long
Dim dArray()                            As Variant
Dim sResult                             As String
 
    dArray() = Array(1, 2, 3, 4, 4, 5, 6, 7, 7, 7, 65, 345, 4545, 4546, 4547, 9999999, 9999999999#)
 
    With Abbreviate_Numeric_Array(dArray)
        For Q = 1 To .Count
            sResult = sResult & .Item(Q) & "|"
        Next Q
    End With
 
    Debug.Print sResult
End Sub

Obtengo esto:

---

Ahora mi funcion para desabreviar...

'=========================================================
' º Function : DeAbbreviate_Numeric_Array
' º Author   : Mr. Frog ©
' º Mail     : vbpsyke1@mixmail.com
' º Recommended Websites :
'       http://blog.visual-coders.com.ar/
'       http://InfrAngeluX.Sytes.Net/
'=========================================================
Option Explicit
Option Base 0
 
Public Function DeAbbreviate_Numeric_Array(ByRef sNumbersItems() As String) As cCollectionEx
If (Not sNumbersItems) = -1 Then Exit Function
Dim cExTemp                                         As New cCollectionEx
Dim sActualItem                                     As String
Dim sNumbers()                                      As String
Dim lToTalItems                                     As Long
Dim Q                                               As Long
Dim W                                               As Long
    lToTalItems = UBound(sNumbersItems())
    If lToTalItems > 2 Then
        For Q = 0 To lToTalItems
            sActualItem = sNumbersItems(Q)
            If sActualItem Like "*~*" Then
                sNumbers() = Split(sActualItem, "~")
                For W = CDbl(sNumbers(0)) To CDbl(sNumbers(1))
                    cExTemp.Add W
                Next W
            Else
                cExTemp.Add sActualItem
            End If
        Next Q
        Set DeAbbreviate_Numeric_Array = cExTemp
    End If
End Function

Un ejemplo:

Private Sub Form_Load()
Dim sArray()                    As String
Dim Q                           As Long
 
    sArray() = Split("1|2|8|9|34|56~58|9999~10002|", "|")
    With DeAbbreviate_Numeric_Array(sArray())
        For Q = 1 To .Count
            Debug.Print .Item(Q)
        Next Q
    End With
End Sub

Me da esto:

DoEvents!

Me ha gustado , ahora falta que hagas la funcion que des-abrevia , si no esto no tiene utilidad
Seria interesante que tambien pudiese detectar series de multiples por ejemplo...

Lo unico que no me gusta es que abusas de hacer las cosas en una linea, por ejemplo:

If lActualNumber + c = lNumberList(n) Then n = n + 1: c = c + 1 Else Exit Do

A me me gusta mucho mas asi, se ve mejor la logica:

If lActualNumber + c = lNumberList(n) Then
       n = n + 1
       c = c + 1 
Else 
       Exit Do
End If

Saludos

A mi también me ha gustado y estoy de acuerdo con eso con Karcrack, hay que hacer el código un poco más legible..(y hasta aunque sea para uno mismo)

Buen trabajo

@Karcrack
Te odio!!!
Queria hacerlo yo antes...
No obstante no voy a mirar tu code, y publicare mi alternativa, despues mirare el tuyo...

JAJAJAJA

Salu2!

Aun le falta...!¡.


Resultado:


Sangriento Infierno Lunar!¡.