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. :D
Para ordenarlo aconsejo usar esta maravillosa función que hizo mi amigo BlackZer0x (http://foro.elhacker.net/profiles/blackzerox961996199618961896179617-u59494.html) :
http://goo.gl/RG4Bx
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:
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:
------------------------------ 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 ) :
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:
(http://infrangelux.sytes.net/FileX/view.php?InfraFile=/Banana-with-3D-glasses.png)
DoEvents! :P
.
grandiosa, aun que ¿Con listas enormes es igual de rápida?.
P.D.: Te tardaste siglos xP.
Dulces Lunas!¡.
Cita de: BlackZeroX▓▓▒▒░░ en 9 Mayo 2011, 19:18 PM
.
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:
(http://infrangelux.sytes.net/FileX/view.php?InfraFile=/df.png)
Ya sé que tardé un poco :silbar:, pero yo no rompo una promesa. :D
DoEvents! :P
.
Gran trabajo xD, ahora a estudiar tu código por que es alucinante.
Dulces Lunas!¡.
.
Código mejorado y ahora con la posibilidad de escanear arrays desordenados.
DoEvents! :P
acabo de hacer el test de otra manera y resulta que ahora la mia es mas rapida que la tuya...
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!¡.
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? :huh:
DoEvents! :P
.
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) (http://infrangelux.sytes.net/filex/index.php?dir=/BlackZeroX/Programacion/vb6/Retos/find%20in%20array&file=test%20findinarray.zip)
(http://infrangelux.sytes.net/filex/view.php?InfraFile=/BlackZeroX/Programacion/vb6/Retos/find%20in%20array/screentest.png)
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!¡.
Wow, impresionante. Muy buen trabajo los 2. Mirare los codigos y los usare en mis proyectos :) Sigan asi
.
Actualice el código de mi función.
Temibles Lunas!¡.
Cita de: BlackZeroX▓▓▒▒░░ en 2 Junio 2011, 04:47 AM
.
Actualice el código de mi función.
Temibles Lunas!¡.
Muy bueno, buen trabajo. :)
Resulta muy divertido empezar a sacar versiones de una misma cosa a ver quien lo hace mejor. :)
Veo que te basaste en la mía... :silbar:
DoEvents! :P
.
De hecho solo saque la lógica de comparar lpos, si se genera dos veces entonces se haría un bucle infinito que no tendría caso alguno, lo demás es lo mismo de mi código.
Solo reemplace las lineas sombreadas... aun que si quitaba la 2da linea entonces tendria que meter un rango de comparacion...
option explicit
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
Para que veas también quedaría con una simple modificación sin aplicar nada ni sacar nada de tu código (aun que a mi me gusto la lógica de comparar lpos con su anterior valor); aun sigue siendo mas rápida que tu función con esta simple modificación...
option explicit
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
Public Function ExitsInArray(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
SwapVals lng_lb, lng_Ub
End If
Select Case vValue
Case vBuff&(lng_lb&)
p& = lng_lb&
ExitsInArray = True
Case vBuff&(lng_Ub&)
p& = lng_Ub&
ExitsInArray = True
Case Else
Do Until ExitsInArray
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
ExitsInArray = True
End If
Else
Exit Do
End If
Loop
End Select
End Function
por otro lado en tu código:
La variable c debería espesar desde lngLB ya que esta toma el valor desde lngStart, aun que aun asi estaría bien pero bueno no afecta en lo absoluto en nada.
No entiendo para que es el parámetro bolFindStart deberías documentar un poco tu código (parámetros de entrada, trabajo de la función y resultados de la misma, mas no linea a linea)
Dulces Lunas!¡.