[Src] IsInArray

[Psyke1]

Bueno, aquí os dejo esta sencilla función.
Su finalidad es devolver el Index de un Item que se encuentre en un array (acepta todo tipo de Arrays : String, Double, Long...), con la opción de devolver el primero que se encuentre en el array y con los parámetros lngStart y lngEnd podemos establecer límites en nuestra búsqueda.  
Para ordenarlo aconsejo usar esta maravillosa función que hizo mi amigo BlackZer0x :
http://goo.gl/RG4Bx

Código (vb) [Seleccionar] Expandir

Option Explicit
'======================================================================
' º Function  : IsInArray
' º Author    : Psyke1
' º Country   : Spain
' º Mail      : vbpsyke1@mixmail.com
' º Date      : 09/05/2011
' º Twitter   : http://twitter.com/#!/PsYkE1
' º Dedicated : BlackZer0x
' º Reference : http://goo.gl/RDQhK
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://www.frogcheat.com.ar
'       http://InfrAngeluX.Sytes.Net
'======================================================================
Public Static Function IsInArray&(varArr, _
                                 varValue, _
                                 Optional lngStart&, _
                                 Optional lngEnd&, _
                                 Optional bolFindFirst As Boolean, _
                                 Optional bolIsSorted As Boolean)
Dim lngLB&, lngUB&, Q&, C&
   If (IsArray(varArr) = True) And (IsArray(varValue) = False) Then
       lngLB = LBound(varArr)
       lngUB = UBound(varArr)

       If Not IsMissing(lngStart) Then
          If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart
       End If
       If Not IsMissing(lngEnd) Then
          If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd
       End If

       If bolIsSorted Then
           If varArr(lngLB) = varValue Then
               IsInArray = lngLB
               Exit Function
           ElseIf varArr(lngUB) = varValue Then
               If bolFindFirst Then
                   Do While (varArr(lngUB) = varArr(lngUB - 1)) And (Q > lngLB)
                       lngUB = lngUB - 1
                   Loop
               End If
               
               IsInArray = lngUB
               Exit Function
           End If

           If lngUB - lngLB < 2 Then GoTo NotFound
           If (varArr(lngLB) > varValue) Or (varArr(lngUB) < varValue) Then GoTo NotFound

           C = 0
           Do
               Q = (lngUB + lngLB) \ 2
               If C = Q Then GoTo NotFound
               
               If varArr(Q) > varValue Then
                   lngUB = Q
               ElseIf varArr(Q) < varValue Then
                   lngLB = Q
                   C = lngLB
               Else
                   If bolFindFirst Then
                       Do While (varArr(Q) = varArr(Q - 1)) And (Q > lngLB)
                           Q = Q - 1
                       Loop
                   End If
                   
                   IsInArray = Q
                   Exit Function
               End If
           Loop
       Else
           For Q = lngLB To lngUB
               If varArr(Q) = varValue Then
                   IsInArray = Q
                   Exit Function
               End If
           Next Q
           
           GoTo NotFound
       End If
   End If
Exit Function

NotFound:
   IsInArray = -1
End Function

Un ejemplo:

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Const strLine$ = "------------------------------"

Private Sub Form_Load()
Dim L&(60), S(), Q&

   For Q = 0 To 60
       L(Q) = Q * 2
   Next Q

   Debug.Print strLine$, Time$, strLine$
   Debug.Print IsInArray(L, 15)                '---> -1
   Debug.Print IsInArray(L, 40)                '--->  20
   Debug.Print IsInArray(L, 85)                '---> -1
   Debug.Print IsInArray(L, 100)               '--->  50

   S = Array("abba", "acero", "karcrack", "sereno", "silencio", "tonto", "tonto", "tonto", "tonto", "zalme")

   Debug.Print strLine$
   Debug.Print IsInArray(S, "zalme")           '--->  9
   Debug.Print IsInArray(S, "zalme", , 4)      '---> -1
   Debug.Print IsInArray(S, "mesa")            '---> -1
   Debug.Print IsInArray(S, "besos")           '---> -1
   Debug.Print IsInArray(S, "karcrack")        '--->  2
   Debug.Print IsInArray(S, "karcrack", 3)     '---> -1
   Debug.Print IsInArray(S, "tonto")           '--->  6
   Debug.Print IsInArray(S, "tonto", , , True) '--->  5
End Sub

Retorna:

Código [Seleccionar] Expandir

------------------------------            18:59:54      ------------------------------
-1
20
-1
50
------------------------------
9
-1
-1
-1
2
-1
6
5



Si necesitamos especial velocidad y lo queremos para un tipo de variable en concreto, sólo hay que modificar un par de cosas.
Aquí un ejemplo para buscar en un array Long, comparado con el código de BlackZer0x ( http://goo.gl/RDQhK ) :

Código [Seleccionar] Expandir

Option Explicit
'// Compilado sin la comprobación de límites en los arrays xP

Private Sub Form_Load()
Dim L&(6000), Q&, t As New CTiming, y&
   
   If App.LogMode = 0 Then End
   
   For Q = 0 To 6000
       L(Q) = Q * 2
   Next Q
   
   Me.AutoRedraw = True
   
   t.Reset
   For Q = 1 To 1000
       IsInArray L, 15
       IsInArray L, 40
       IsInArray L, 2001
       IsInArray L, 5020
       IsInArray L, 12000
   Next Q
   Me.Print "IsInArray", , t.sElapsed
   
   t.Reset
   For Q = 1 To 1000
       ExitsInArrayNR 15, L, y
       ExitsInArrayNR 40, L, y
       ExitsInArrayNR 2001, L, y
       ExitsInArrayNR 5020, L, y
       ExitsInArrayNR 12000, L, y
   Next Q
   Me.Print "ExitsInArrayNR", t.sElapsed
End Sub

'// by Psyke1
Public Static Function IsInArray&(lngArr&(), lngValue&, Optional lngStart&, Optional lngEnd&, Optional bolFindFirst As Boolean)
Dim lngLB&, lngUB&, lngItem&, Q&, C&
   lngLB = LBound(lngArr)
   lngUB = UBound(lngArr)
   
   If Not IsMissing(lngStart) Then
      If (lngStart > lngLB) And (lngStart < lngUB) Then lngLB = lngStart
   End If
   If Not IsMissing(lngEnd) Then
      If (lngEnd > lngLB) And (lngEnd < lngUB) Then lngUB = lngEnd
   End If
   
   If lngArr(lngLB) = lngValue Then
       IsInArray = lngLB
       Exit Function
   ElseIf lngArr(lngUB) = lngValue Then
       If bolFindFirst Then
           Do While (lngArr(lngUB) = lngArr(lngUB - 1)) And (Q > lngLB)
               lngUB = lngUB - 1
           Loop
       End If
       IsInArray = lngUB
       Exit Function
   End If
   
   If lngUB - lngLB < 2 Then GoTo NotFound
   If (lngArr(lngLB) > lngValue) Or (lngArr(lngUB) < lngValue) Then GoTo NotFound
   
   C = 0
   Do
       Q = (lngUB + lngLB) \ 2
       If C = Q Then GoTo NotFound

       If lngArr(Q) > lngValue Then
           lngUB = Q
       ElseIf lngArr(Q) < lngValue Then
           lngLB = Q
           C = lngLB
       Else
           If bolFindFirst Then
               Do While (lngArr(Q) = lngArr(Q - 1)) And (Q > lngLB)
                   Q = Q - 1
               Loop
           End If
           IsInArray = Q
           Exit Function
       End If
   Loop
Exit Function

NotFound:
   IsInArray = -1
End Function

'// by BlackZer0x
Public Function ExitsInArrayNR(ByRef vValue As Long, ByRef vBuff() As Long, ByRef p As Long) As Boolean
Dim lng_lb                      As Long
Dim lng_Ub                      As Long
   lng_lb = LBound(vBuff&())
   lng_Ub = UBound(vBuff&())
   If Not vBuff&(lng_Ub) > vBuff&(lng_lb) Then
       Dim t                           As Long
       t = lng_Ub
       lng_Ub = lng_lb
       lng_lb = t
   End If
   Do Until ExitsInArrayNR
       Select Case vValue
           Case vBuff&(lng_lb&)
               p& = lng_lb&
               ExitsInArrayNR = True
           Case vBuff&(lng_Ub&)
               p& = lng_Ub&
               ExitsInArrayNR = True
           Case Else
               p = (lng_lb& + lng_Ub&) / 2
               If p <> lng_lb& And p& <> lng_Ub& Then
                   If vBuff&(p&) < vValue& Then
                       lng_lb = p
                   ElseIf vBuff&(p&) > vValue& Then
                       lng_Ub = p
                   ElseIf vBuff&(p&) = vValue& Then
                       ExitsInArrayNR = True
                   End If
               Else
                   Exit Do
               End If
       End Select
   Loop
End Function

Resultado:


DoEvents!

[BlackZeroX]

.
grandiosa, aun que ¿Con listas enormes es igual de rápida?.

P.D.: Te tardaste siglos xP.

Dulces Lunas!¡.

[Psyke1]

.
grandiosa, aun que ¿Con listas enormes es igual de rápida?.

P.D.: Te tardaste siglos xP.

Dulces Lunas!¡.

Gracias
Sí, la velocidad es rápida incluso con arrays graandes.
Cambié el tamaño del Array referente al test de 6000 a 99999999 y me devuelve esto:


Ya sé que tardé un poco , pero yo no rompo una promesa.

DoEvents!

[BlackZeroX]

.
Gran trabajo xD, ahora a estudiar tu código por que es alucinante.

Dulces Lunas!¡.

[Psyke1]

.
Código mejorado y ahora con la posibilidad de escanear arrays desordenados.

DoEvents!

[BlackZeroX]

acabo de hacer el test de otra manera y resulta que ahora la mia es mas rapida que la tuya...

Código [Seleccionar] Expandir



Private Sub Form_Load()
Dim L&(6000), Q&, t As New CTiming, y&
   
    If App.LogMode = 0 Then End
   
    For Q = 0 To 6000
        L(Q) = Q * 2
    Next Q
   
    Me.AutoRedraw = True
   
        t.Reset
    For Q = 1 To 1000
        ExitsInArrayNR 15, L, y
        ExitsInArrayNR 40, L, y
        ExitsInArrayNR 2001, L, y
        ExitsInArrayNR 5020, L, y
        ExitsInArrayNR 12000, L, y
    Next Q
    Me.Print "ExitsInArrayNR", t.sElapsed
   
    t.Reset
    For Q = 1 To 1000
        IsInArray L, 15
        IsInArray L, 40
        IsInArray L, 2001
        IsInArray L, 5020
        IsInArray L, 12000
    Next Q
    Me.Print "IsInArray", , t.sElapsed
   

End Sub



Dulces Lunas!¡.

[Psyke1]

Supongo que me has dejado la función como Variant y las variables como Variant.
Ya dije en el test que cambié un par de cosas en mi función.
¿Se puede saber que cambiaste en tu test?

DoEvents!

[BlackZeroX]

.
Así queda mejor (Todo lo demás es solo una expansion...):

Revise nuevamente mi código y vi que no eran necesarias las comparaciones dentro del do-loop de los indices lbound y ubound o las sustituciones, ya que el que importa es el elemento medio.

Código Fuente de prueba (Test Aleatorio)

Código (Vb) [Seleccionar] Expandir



Private Sub SwapVals(ByRef lVal1 As Long, ByRef lval2 As Long)
    lval2 = lval2 Xor lVal1
    lVal1 = lVal1 Xor lval2
    lval2 = lval2 Xor lVal1
End Sub

'Return (Devuelve True si existe en el array)
Public Function ExitsInArray(ByRef lFind As Long, ByRef avBuff() As Long, ByRef lpos As Long) As Boolean
Dim llb             As Long
Dim lub             As Long
Dim lposa           As Long
    'If Itsarrayini(VarPtrA(avBuff())) Then
        llb = LBound(avBuff)
        lub = UBound(avBuff)
        If (avBuff(lub) < avBuff(llb)) Then
            SwapVals lub, llb
        End If
        If ((avBuff(llb) <= lFind) And (lFind <= avBuff(lub))) Then
            Select Case lFind
                Case avBuff(lub)
                    lpos = lub
                    ExitsInArray = True
                Case avBuff(llb)
                    lpos = llb
                    ExitsInArray = True
                Case Else
                    lposa = llb
                    Do
                        lpos = (llb + lub) \ 2
                        If (lposa = lpos) Then
                            Exit Do
                        ElseIf (avBuff(lpos) > lFind) Then
                            lub = lpos
                        ElseIf (lFind > avBuff(lpos)) Then
                            lposa = lpos
                            llb = lpos
                        ElseIf (avBuff(lpos) = lFind) Then
                            ExitsInArray = True
                            Exit Do
                        End If
                    Loop
            End Select
        End If
    'End If
End Function



Dulces Lunas!¡.

[raul338]

Wow, impresionante. Muy buen trabajo los 2. Mirare los codigos y los usare en mis proyectos Sigan asi

[BlackZeroX]

.
Actualice el código de mi función.

Temibles Lunas!¡.