[SRC] Abbreviate_Numeric_Array [by *PsYkE1]

[Psyke1]

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

Código (vb) [Seleccionar] Expandir


'=========================================================
' º 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:

Código (vb) [Seleccionar] Expandir


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:

1~7|65|345|4545~4547|9999999|9999999999|

Ahora mi funcion para desabreviar...

Código (vb) [Seleccionar] Expandir


'=========================================================
' º 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:

Código (vb) [Seleccionar] Expandir


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:

1
2
8
9
34
56
57
58
9999
10000
10001
10002

DoEvents!

[Debci]

Es un muy buen ejercicio para pillar conceptos de lógica.

Muy bueno y gracias por compartir

Saludos

[Karcrack]

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:

Código (vb) [Seleccionar] Expandir

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:

Código (vb) [Seleccionar] Expandir

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

Saludos

[Psyke1]

Gracias!
Si, lo de las series multiples era una de las cosas a implementar, buena idea lo de "des-abreviar"... (Lo metere tambien, buena idea)
En cuanto lo de las lineas es pura costumbre, auque tienes razon que es mas "entendible" como me has puesto...
En unos dias posteo la nueva

Salu2 y Gracias a ambos!

[Dreamaker]

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]

He hecho la funcion de desabreviar

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Sub Form_Load()
   Dim vItem       As Variant
   
   For Each vItem In DeAbbreviate("1|2|8|9|34|56~58|9999~10002|")
       Debug.Print vItem;
   Next vItem
End Sub

Public Function DeAbbreviate(ByVal sString As String) As Double()
   Dim bvTemp()    As String
   Dim i           As Long
   Dim n           As Long
   Dim w           As Long
   Dim dFir        As Double
   Dim dLas        As Double
   Dim bvResult()  As Double
   
   bvTemp = Split(sString, "|")
   
   For i = LBound(bvTemp) To UBound(bvTemp)
       If bvTemp(i) Like "*~*" Then
           dFir = Val(Split(bvTemp(i), "~")(0))
           dLas = Val(Split(bvTemp(i), "~")(1))
           ReDim Preserve bvResult(0 To (n + (dLas - dFir)))
           For n = n To (n + (dLas - dFir))
               bvResult(n) = dFir + w
               w = w + 1
           Next n
           w = 0
           n = n - 1
       ElseIf bvTemp(i) <> vbNullString Then
           ReDim Preserve bvResult(0 To n)
           bvResult(n) = bvTemp(i)
       End If
       n = n + 1
   Next i
   
   DeAbbreviate = bvResult
End Function

Supongo que se podria acortar un poco, pero creo que asi queda muy claro lo que hace

Saludos

[Psyke1]

@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!

[Psyke1]

Bueno como habeis visto, he posteado la funcion de desabreviar  
Tambien he quitado algunos ":" para que la funcion sea mas legible (siguiendo vuestro consejo )
Voy a ver tu funcion Karcrack, aunque debo de admitir que hay cosas que no entiendo, las buscare y si tengo dudas pregunto...

Salu2 y Gracias!

[BlackZeroX]

Aun le falta...!¡.

Código [Seleccionar] Expandir



Dim tt(100) As Double
tt(0) = 6
tt(1) = 8
tt(2) = 9
tt(3) = 10
tt(4) = 11
tt(5) = 12
tt(6) = 12
tt(7) = 12
tt(8) = 13
tt(9) = 14
tt(10) = 15
tt(11) = 16
tt(12) = 17
tt(13) = 18
tt(14) = 19
tt(15) = 19
tt(16) = 19
tt(17) = 20
tt(18) = 20
tt(19) = 21
tt(20) = 21
tt(21) = 22
tt(22) = 23
tt(23) = 24
tt(24) = 24
tt(25) = 25
tt(26) = 25
tt(27) = 25
tt(28) = 27
tt(29) = 28
tt(30) = 29
tt(31) = 31
tt(32) = 33
tt(33) = 34
tt(34) = 34
tt(35) = 35
tt(36) = 35
tt(37) = 37
tt(38) = 37
tt(39) = 38
tt(40) = 39
tt(41) = 40
tt(42) = 43
tt(43) = 43
tt(44) = 44
tt(45) = 44
tt(46) = 45
tt(47) = 45
tt(48) = 46
tt(49) = 47
tt(50) = 48
tt(51) = 48
tt(52) = 48
tt(53) = 49
tt(54) = 50
tt(55) = 50
tt(56) = 52
tt(57) = 54
tt(58) = 56
tt(59) = 56
tt(60) = 56
tt(61) = 57
tt(62) = 59
tt(63) = 60
tt(64) = 61
tt(65) = 62
tt(66) = 63
tt(67) = 64
tt(68) = 65
tt(69) = 66
tt(70) = 66
tt(71) = 67
tt(72) = 69
tt(73) = 70
tt(74) = 70
tt(75) = 72
tt(76) = 73
tt(77) = 74
tt(78) = 75
tt(79) = 75
tt(80) = 76
tt(81) = 76
tt(82) = 77
tt(83) = 80
tt(84) = 81
tt(85) = 85
tt(86) = 87
tt(87) = 88
tt(88) = 88
tt(89) = 89
tt(90) = 89
tt(91) = 91
tt(92) = 92
tt(93) = 92
tt(94) = 94
tt(95) = 94
tt(96) = 95
tt(97) = 95
tt(98) = 96
tt(99) = 96
tt(100) = 97



Resultado:

Código [Seleccionar] Expandir



6|8~12|12|12~19|19|19|20|20|21|21~24|24|25|25|25|27~29|31|33|34|34|35|35|37|37~40|43|43|44|44|45|45~48|48|48~50|50|52|54|56|56|56|57|59~66|66|67|69|70|70|72~75|75|76|76|77|80|81|85|87|88|88|89|89|91|92|92|94|94|95|95|96|96|97|



Sangriento Infierno Lunar!¡.

[Psyke1]

Si si Black!
Ya dije que faltaba eso aun...
Lo corrigo en estos dias...

Salu2!