Autor
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
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
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:
------------------------------ 18:59:54 ------------------------------
-1
20
-1
50
------------------------------
9
-1
-1
-1
2
-1
6
5
-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:
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
'// 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!
En línea
, pero yo no rompo una promesa. 
